Changeset 6455
- Timestamp:
- 2016-04-08T10:57:55+02:00 (8 years ago)
- Location:
- branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM
- Files:
-
- 8 deleted
- 105 edited
- 22 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/ARCH/CMCC/arch-ifort_athena_xios.fcm
r6232 r6455 34 34 35 35 # required modules 36 # module load INTEL/intel_xe_2013 NETCDF/netcdf-4.3_parallel _shared NETCDF/parallel-netcdf-1.3.1 HDF5/hdf5-1.8.11_parallel_shared36 # module load INTEL/intel_xe_2013 NETCDF/netcdf-4.3_parallel NETCDF/parallel-netcdf-1.3.1 HDF5/hdf5-1.8.11_parallel 37 37 38 38 # Environment variables set by user. Others should automatically define when loading modules. 39 39 #export XIOS=/users/home/models/nemo/xios 40 #export HDF5=/users/home/opt/hdf5/hdf5-1.8.11_parallel _shared41 #export NETCDF=/users/home/opt/netcdf/netcdf-4.3_parallel _shared40 #export HDF5=/users/home/opt/hdf5/hdf5-1.8.11_parallel 41 #export NETCDF=/users/home/opt/netcdf/netcdf-4.3_parallel 42 42 43 43 %NCDF_INC -I${NETCDF}/include … … 49 49 %CPP cpp 50 50 %FC mpiifort 51 %FCFLAGS -r8 -O3 -xHost -fp-model source -traceback ${CFLAGS}51 %FCFLAGS -r8 -O3 -xHost -fp-model source -traceback 52 52 %FFLAGS %FCFLAGS 53 53 %LD mpiifort 54 54 %FPPFLAGS -P -C -traditional 55 %LDFLAGS -lstdc++ -lz -lgpfs -lcurl ${LDFLAGS}55 %LDFLAGS -lstdc++ -lz -lgpfs -lcurl 56 56 %AR ar 57 57 %ARFLAGS -r -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/AMM12/EXP00/namelist_cfg
r5501 r6455 200 200 / 201 201 !----------------------------------------------------------------------- 202 &namobc ! open boundaries parameters ("key_obc")203 !-----------------------------------------------------------------------204 /205 !-----------------------------------------------------------------------206 202 &namagrif ! AGRIF zoom ("key_agrif") 207 203 !----------------------------------------------------------------------- … … 369 365 / 370 366 !----------------------------------------------------------------------- 367 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 368 !----------------------------------------------------------------------- 369 / 370 !----------------------------------------------------------------------- 371 371 &namsol ! elliptic solver / island / free surface 372 372 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/C1D_PAPA/EXP00/namelist_cfg
r5925 r6455 179 179 / 180 180 !----------------------------------------------------------------------- 181 &namobc ! open boundaries parameters ("key_obc")182 !-----------------------------------------------------------------------183 /184 !-----------------------------------------------------------------------185 181 &namagrif ! AGRIF zoom ("key_agrif") 186 182 !----------------------------------------------------------------------- … … 307 303 / 308 304 !----------------------------------------------------------------------- 305 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 306 !----------------------------------------------------------------------- 307 / 308 !----------------------------------------------------------------------- 309 309 &namsol ! elliptic solver / island / free surface 310 310 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/GYRE/EXP00/namelist_cfg
r5407 r6455 160 160 / 161 161 !----------------------------------------------------------------------- 162 &namobc ! open boundaries parameters ("key_obc")163 !-----------------------------------------------------------------------164 /165 !-----------------------------------------------------------------------166 162 &namagrif ! AGRIF zoom ("key_agrif") 167 163 !----------------------------------------------------------------------- … … 304 300 / 305 301 !----------------------------------------------------------------------- 302 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 303 !----------------------------------------------------------------------- 304 / 305 !----------------------------------------------------------------------- 306 306 &namsol ! elliptic solver / island / free surface 307 307 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/GYRE_BFM/EXP00/namelist_cfg
r5407 r6455 165 165 / 166 166 !----------------------------------------------------------------------- 167 &namobc ! open boundaries parameters ("key_obc")168 !-----------------------------------------------------------------------169 /170 !-----------------------------------------------------------------------171 167 &namagrif ! AGRIF zoom ("key_agrif") 172 168 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/GYRE_XIOS/EXP00/namelist_cfg
r5407 r6455 154 154 / 155 155 !----------------------------------------------------------------------- 156 &namobc ! open boundaries parameters ("key_obc")157 !-----------------------------------------------------------------------158 /159 !-----------------------------------------------------------------------160 156 &namagrif ! AGRIF zoom ("key_agrif") 161 157 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/ORCA2_LIM/EXP00/namelist_cfg
r4990 r6455 165 165 / 166 166 !----------------------------------------------------------------------- 167 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 168 !----------------------------------------------------------------------- 169 / 170 !----------------------------------------------------------------------- 167 171 &namsol ! elliptic solver / island / free surface 168 172 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/iodef.xml
r5517 r6455 61 61 <file id="file2" name_suffix="_SBC" description="surface fluxes variables" > <!-- time step automaticaly defined based on nn_fsbc --> 62 62 <field field_ref="empmr" name="wfo" /> 63 <field field_ref="emp_oce" name="emp_oce" long_name="Evap minus Precip over ocean" /> 64 <field field_ref="emp_ice" name="emp_ice" long_name="Evap minus Precip over ice" /> 63 65 <field field_ref="qsr_oce" name="qsr_oce" /> 64 66 <field field_ref="qns_oce" name="qns_oce" /> -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/ORCA2_LIM3/EXP00/namelist_cfg
r4995 r6455 168 168 / 169 169 !----------------------------------------------------------------------- 170 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 171 !----------------------------------------------------------------------- 172 / 173 !----------------------------------------------------------------------- 170 174 &namsol ! elliptic solver / island / free surface 171 175 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/1_namelist_cfg
r5407 r6455 5 5 !! namsbc_cpl, namtra_qsr, namsbc_rnf, 6 6 !! namsbc_apr, namsbc_ssr, namsbc_alb) 7 !! 4 - lateral boundary (namlbc, namcla, nam obc, namagrif, nambdy, nambdy_tide)7 !! 4 - lateral boundary (namlbc, namcla, namagrif, nambdy, nambdy_tide) 8 8 !! 5 - bottom boundary (nambfr, nambbc, nambbl) 9 9 !! 6 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_dmp) … … 303 303 !! namlbc lateral momentum boundary condition 304 304 !! namcla cross land advection 305 !! namobc open boundaries parameters ("key_obc")306 305 !! namagrif agrif nested grid ( read by child model only ) ("key_agrif") 307 306 !! nambdy Unstructured open boundaries ("key_bdy") … … 319 318 !----------------------------------------------------------------------- 320 319 nn_cla = 0 ! advection between 2 ocean pts separates by land 321 /322 !-----------------------------------------------------------------------323 &namobc ! open boundaries parameters ("key_obc")324 !-----------------------------------------------------------------------325 ln_obc_clim = .false. ! climatological obc data files (T) or not (F)326 ln_vol_cst = .true. ! impose the total volume conservation (T) or not (F)327 ln_obc_fla = .false. ! Flather open boundary condition328 nn_obcdta = 1 ! = 0 the obc data are equal to the initial state329 ! = 1 the obc data are read in 'obc.dta' files330 cn_obcdta = 'annual' ! set to annual if obc datafile hold 1 year of data331 ! set to monthly if obc datafile hold 1 month of data332 rn_dpein = 1. ! damping time scale for inflow at east open boundary333 rn_dpwin = 1. ! - - - west - -334 rn_dpnin = 1. ! - - - north - -335 rn_dpsin = 1. ! - - - south - -336 rn_dpeob = 3000. ! time relaxation (days) for the east open boundary337 rn_dpwob = 15. ! - - - west - -338 rn_dpnob = 3000. ! - - - north - -339 rn_dpsob = 15. ! - - - south - -340 rn_volemp = 1. ! = 0 the total volume change with the surface flux (E-P-R)341 ! = 1 the total volume remains constant342 320 / 343 321 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/ORCA2_LIM_CFC_C14b/EXP00/namelist_cfg
r5407 r6455 136 136 / 137 137 !----------------------------------------------------------------------- 138 &namobc ! open boundaries parameters ("key_obc")139 !-----------------------------------------------------------------------140 /141 !-----------------------------------------------------------------------142 138 &namagrif ! AGRIF zoom ("key_agrif") 143 139 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/ORCA2_LIM_PISCES/EXP00/namelist_cfg
r4370 r6455 165 165 / 166 166 !----------------------------------------------------------------------- 167 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 168 !----------------------------------------------------------------------- 169 / 170 !----------------------------------------------------------------------- 167 171 &namsol ! elliptic solver / island / free surface 168 172 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/SHARED/field_def.xml
r5517 r6455 23 23 <field_group id="grid_T" grid_ref="grid_T_2D" > 24 24 <field id="e3t" long_name="T-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_T_3D"/> 25 <field id="e3t_0" long_name="Initial T-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_T_3D"/> 25 26 26 27 <field id="toce" long_name="temperature" standard_name="sea_water_potential_temperature" unit="degC" grid_ref="grid_T_3D"/> … … 59 60 <field id="alpha" long_name="thermal expansion" unit="degC-1" grid_ref="grid_T_3D" /> 60 61 <field id="beta" long_name="haline contraction" unit="1e3" grid_ref="grid_T_3D" /> 61 <field id="bn2" long_name="squared Brunt-Vaisala frequency" unit="s-1" grid_ref="grid_T_3D" />62 62 <field id="rhop" long_name="potential density (sigma0)" standard_name="sea_water_sigma_theta" unit="kg/m3" grid_ref="grid_T_3D" /> 63 63 … … 174 174 <field_group id="SBC" grid_ref="grid_T_2D" > <!-- time step automaticaly defined based on nn_fsbc --> 175 175 <field id="empmr" long_name="Net Upward Water Flux" standard_name="water_flux_out_of_sea_ice_and_sea_water" unit="kg/m2/s" /> 176 <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" /> 177 <field id="emp_oce" long_name="Evap minus Precip over ocean" standard_name="evap_minus_precip_over_sea_water" unit="kg/m2/s" /> 178 <field id="emp_ice" long_name="Evap minus Precip over ice" standard_name="evap_minus_precip_over_sea_ice" unit="kg/m2/s" /> 176 179 <field id="saltflx" long_name="Downward salt flux" unit="1e-3/m2/s" /> 177 180 <field id="fmmflx" long_name="Water flux due to freezing/melting" unit="kg/m2/s" /> … … 274 277 <field id="micesalt" long_name="Mean ice salinity" unit="1e-3" /> 275 278 <field id="miceage" long_name="Mean ice age" unit="years" /> 279 <field id="alb_ice" long_name="Mean albedo over sea ice" unit="" /> 280 <field id="albedo" long_name="Mean albedo over sea ice and ocean" unit="" /> 276 281 277 282 <field id="iceage_cat" long_name="Ice age for categories" unit="days" axis_ref="ncatice" /> … … 311 316 <field id="sfxsni" long_name="salt flux from snow-ice formation" unit="1e-3*kg/m2/day" /> 312 317 <field id="sfxopw" long_name="salt flux from open water ice formation" unit="1e-3*kg/m2/day" /> 318 <field id="sfxsub" long_name="salt flux from sublimation" unit="1e-3*kg/m2/day" /> 313 319 <field id="sfx" long_name="salt flux total" unit="1e-3*kg/m2/day" /> 314 320 … … 324 330 <field id="vfxsub" long_name="snw sublimation" unit="m/day" /> 325 331 <field id="vfxspr" long_name="snw precipitation on ice" unit="m/day" /> 332 <field id="vfxthin" long_name="daily thermo ice prod. for thin ice(<20cm) + open water" unit="m/day" /> 326 333 327 334 <field id="afxtot" long_name="area tendency (total)" unit="day-1" /> … … 365 372 <field_group id="grid_U" grid_ref="grid_U_2D"> 366 373 <field id="e3u" long_name="U-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_U_3D" /> 374 <field id="e3u_0" long_name="Initial U-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_U_3D"/> 367 375 <field id="utau" long_name="Wind Stress along i-axis" standard_name="surface_downward_x_stress" unit="N/m2" /> 368 376 <field id="uoce" long_name="ocean current along i-axis" standard_name="sea_water_x_velocity" unit="m/s" grid_ref="grid_U_3D" /> … … 400 408 <field_group id="grid_V" grid_ref="grid_V_2D"> 401 409 <field id="e3v" long_name="V-cell thickness" standard_name="cell_thickness" unit="m" grid_ref="grid_V_3D" /> 410 <field id="e3v_0" long_name="Initial V-cell thickness" standard_name="ref_cell_thickness" unit="m" grid_ref="grid_V_3D"/> 402 411 <field id="vtau" long_name="Wind Stress along j-axis" standard_name="surface_downward_y_stress" unit="N/m2" /> 403 412 <field id="voce" long_name="ocean current along j-axis" standard_name="sea_water_y_velocity" unit="m/s" grid_ref="grid_V_3D" /> … … 441 450 <field id="woce_eiv" long_name="EIV ocean vertical velocity" standard_name="bolus_upward_sea_water_velocity" unit="m/s" /> 442 451 443 <!-- woce_eiv: available with key_trabbl_adv -->444 452 <field id="avt" long_name="vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> 453 <field id="logavt" long_name="logarithm of vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> 445 454 <field id="avm" long_name="vertical eddy viscosity" standard_name="ocean_vertical_momentum_diffusivity" unit="m2/s" /> 446 455 447 456 <!-- avs: available with key_zdfddm --> 448 457 <field id="avs" long_name="salt vertical eddy diffusivity" standard_name="ocean_vertical_salt_diffusivity" unit="m2/s" /> 458 <field id="logavs" long_name="logarithm of salt vertical eddy diffusivity" standard_name="ocean_vertical_heat_diffusivity" unit="m2/s" /> 449 459 450 460 <!-- avt_evd and avm_evd: available with ln_zdfevd --> … … 454 464 <!-- avt_tide: available with key_zdftmx --> 455 465 <field id="av_tide" long_name="tidal vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_tides" unit="m2/s" /> 466 467 <!-- variables available with key_zdftmx_new --> 468 <field id="av_ratio" long_name="S over T diffusivity ratio" standard_name="salinity_over_temperature_diffusivity_ratio" unit="1" /> 469 <field id="av_wave" long_name="wave-induced vertical diffusivity" standard_name="ocean_vertical_tracer_diffusivity_due_to_internal_waves" unit="m2/s" /> 470 <field id="bn2" long_name="squared Brunt-Vaisala frequency" standard_name="squared_brunt_vaisala_frequency" unit="s-1" /> 471 <field id="bflx_tmx" long_name="wave-induced buoyancy flux" standard_name="buoyancy_flux_due_to_internal_waves" unit="W/kg" /> 472 <field id="pcmap_tmx" 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" /> 473 <field id="emix_tmx" long_name="power density available for mixing" standard_name="power_available_for_mixing_from_breaking_internal_waves" unit="W/kg" /> 456 474 457 475 <!-- variables available with key_diaar5 --> … … 527 545 <field id="ibgsfxbom" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> 528 546 <field id="ibgsfxsum" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> 547 <field id="ibgsfxsub" long_name="global mean salt flux (thermo)" unit="1e-3*m/day" /> 529 548 530 549 <field id="ibghfxdhc" long_name="Heat content variation in snow and ice" unit="W" /> … … 849 868 <field id="Totlig" long_name="Total ligand concentation" unit="nmol/m3" grid_ref="grid_T_3D" /> 850 869 <field id="Biron" long_name="Bioavailable iron" unit="nmol/m3" grid_ref="grid_T_3D" /> 851 <field id="Sdenit" long_name="Nitrate reduction in the sediments" unit="mol/m2/s" /> 870 <field id="Sdenit" long_name="Nitrate reduction in the sediments" unit="molN/m2/s" /> 871 <field id="SedCal" long_name="Calcite burial in the sediments" unit="molC/m2/s" /> 872 <field id="SedSi" long_name="Silicon burial in the sediments" unit="molSi/m2/s" /> 873 <field id="SedC" long_name="Organic C burial in the sediments" unit="molC/m2/s" /> 852 874 <field id="Ironice" long_name="Iron input/uptake due to sea ice" unit="mol/m2/s" /> 853 875 <field id="HYDR" long_name="Iron input from hydrothemal vents" unit="mol/m2/s" grid_ref="grid_T_3D" /> -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/SHARED/namelist_ice_lim3_ref
r5429 r6455 21 21 cn_icerst_outdir = "." ! directory in which to write output ice restarts 22 22 ln_limdyn = .true. ! ice dynamics (T) or thermodynamics only (F) 23 rn_amax = 0.999 ! maximum tolerated ice concentration 23 rn_amax_n = 0.999 ! maximum tolerated ice concentration NH 24 rn_amax_s = 0.999 ! maximum tolerated ice concentration SH 24 25 ln_limdiahsb = .false. ! check the heat and salt budgets (T) or not (F) 25 26 ln_limdiaout = .true. ! output the heat and salt budgets (T) or not (F) … … 85 86 rn_hnewice = 0.1 ! thickness for new ice formation in open water (m) 86 87 ln_frazil = .false. ! use frazil ice collection thickness as a function of wind (T) or not (F) 87 rn_maxfrazb = 0.0 ! maximum fraction of frazil ice collecting at the ice base88 rn_maxfrazb = 1.0 ! maximum fraction of frazil ice collecting at the ice base 88 89 rn_vfrazb = 0.417 ! thresold drift speed for frazil ice collecting at the ice bottom (m/s) 89 90 rn_Cfrazb = 5.0 ! squeezing coefficient for frazil ice collecting at the ice bottom -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/SHARED/namelist_ref
r5578 r6455 5 5 !! namsbc_cpl, namtra_qsr, namsbc_rnf, 6 6 !! namsbc_apr, namsbc_ssr, namsbc_alb) 7 !! 4 - lateral boundary (namlbc, namcla, nam obc, namagrif, nambdy, nambdy_tide)7 !! 4 - lateral boundary (namlbc, namcla, namagrif, nambdy, nambdy_tide) 8 8 !! 5 - bottom boundary (nambfr, nambbc, nambbl) 9 9 !! 6 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_dmp) 10 10 !! 7 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) 11 !! 8 - Verical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_kpp, namzdf_ddm, namzdf_tmx )11 !! 8 - Verical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_kpp, namzdf_ddm, namzdf_tmx, namzdf_tmx_new) 12 12 !! 9 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb, namsto) 13 13 !! 10 - miscellaneous (namsol, nammpp, namctl) … … 408 408 ln_qsr_2bd = .false. ! 2 bands light penetration 409 409 ln_qsr_bio = .false. ! bio-model light penetration 410 nn_chldta = 1 ! RGB : Chl data (=1) or cst value (=0)410 nn_chldta = 1 ! RGB : 2D Chl data (=1), 3D Chl data (=2) or cst value (=0) 411 411 rn_abs = 0.58 ! RGB & 2 bands: fraction of light (rn_si1) 412 412 rn_si0 = 0.35 ! RGB & 2 bands: shortess depth of extinction … … 500 500 &namsbc_alb ! albedo parameters 501 501 !----------------------------------------------------------------------- 502 rn_cloud = 0.06 ! cloud correction to snow and ice albedo 503 rn_albice = 0.53 ! albedo of melting ice in the arctic and antarctic 504 rn_alphd = 0.80 ! coefficients for linear interpolation used to 505 rn_alphc = 0.65 ! compute albedo between two extremes values 506 rn_alphdi = 0.72 ! (Pyane, 1972) 502 nn_ice_alb = 0 ! parameterization of ice/snow albedo 503 ! 0: Shine & Henderson-Sellers (JGR 1985) 504 ! 1: "home made" based on Brandt et al. (J. Climate 2005) 505 ! and Grenfell & Perovich (JGR 2004) 506 rn_albice = 0.53 ! albedo of bare puddled ice (values from 0.49 to 0.58) 507 ! 0.53 (default) => if nn_ice_alb=0 508 ! 0.50 (default) => if nn_ice_alb=1 507 509 / 508 510 !----------------------------------------------------------------------- … … 546 548 !! namlbc lateral momentum boundary condition 547 549 !! namcla cross land advection 548 !! namobc open boundaries parameters ("key_obc")549 550 !! namagrif agrif nested grid ( read by child model only ) ("key_agrif") 550 551 !! nambdy Unstructured open boundaries ("key_bdy") … … 563 564 !----------------------------------------------------------------------- 564 565 nn_cla = 0 ! advection between 2 ocean pts separates by land 565 /566 !-----------------------------------------------------------------------567 &namobc ! open boundaries parameters ("key_obc")568 !-----------------------------------------------------------------------569 ln_obc_clim = .false. ! climatological obc data files (T) or not (F)570 ln_vol_cst = .true. ! impose the total volume conservation (T) or not (F)571 ln_obc_fla = .false. ! Flather open boundary condition572 nn_obcdta = 1 ! = 0 the obc data are equal to the initial state573 ! = 1 the obc data are read in 'obc.dta' files574 cn_obcdta = 'annual' ! set to annual if obc datafile hold 1 year of data575 ! set to monthly if obc datafile hold 1 month of data576 rn_dpein = 1. ! damping time scale for inflow at east open boundary577 rn_dpwin = 1. ! - - - west - -578 rn_dpnin = 1. ! - - - north - -579 rn_dpsin = 1. ! - - - south - -580 rn_dpeob = 3000. ! time relaxation (days) for the east open boundary581 rn_dpwob = 15. ! - - - west - -582 rn_dpnob = 3000. ! - - - north - -583 rn_dpsob = 15. ! - - - south - -584 rn_volemp = 1. ! = 0 the total volume change with the surface flux (E-P-R)585 ! = 1 the total volume remains constant586 566 / 587 567 !----------------------------------------------------------------------- … … 898 878 !! Tracers & Dynamics vertical physics namelists 899 879 !!====================================================================== 900 !! namzdf vertical physics 901 !! namzdf_ric richardson number dependent vertical mixing ("key_zdfric") 902 !! namzdf_tke TKE dependent vertical mixing ("key_zdftke") 903 !! namzdf_kpp KPP dependent vertical mixing ("key_zdfkpp") 904 !! namzdf_ddm double diffusive mixing parameterization ("key_zdfddm") 905 !! namzdf_tmx tidal mixing parameterization ("key_zdftmx") 880 !! namzdf vertical physics 881 !! namzdf_ric richardson number dependent vertical mixing ("key_zdfric") 882 !! namzdf_tke TKE dependent vertical mixing ("key_zdftke") 883 !! namzdf_kpp KPP dependent vertical mixing ("key_zdfkpp") 884 !! namzdf_ddm double diffusive mixing parameterization ("key_zdfddm") 885 !! namzdf_tmx tidal mixing parameterization ("key_zdftmx") 886 !! namzdf_tmx_new new tidal mixing parameterization ("key_zdftmx_new") 906 887 !!====================================================================== 907 888 ! … … 1010 991 rn_tfe_itf = 1. ! ITF tidal dissipation efficiency 1011 992 / 1012 993 !----------------------------------------------------------------------- 994 &namzdf_tmx_new ! new tidal mixing parameterization ("key_zdftmx_new") 995 !----------------------------------------------------------------------- 996 nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) 997 ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency 998 ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) 999 / 1013 1000 !!====================================================================== 1014 1001 !! *** Miscellaneous namelists *** -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/SHARED/namelist_top_ref
r5416 r6455 62 62 rn_ahtrc_0 = 2000. ! horizontal eddy diffusivity for tracers [m2/s] 63 63 rn_ahtrb_0 = 0. ! background eddy diffusivity for ldf_iso [m2/s] 64 rn_fact_lap = 1. ! enhanced zonal eddy diffusivity 64 65 / 65 66 !----------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/CONFIG/cfg.txt
r6204 r6455 6 6 GYRE_BFM OPA_SRC TOP_SRC 7 7 AMM12 OPA_SRC 8 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC 8 9 ORCA2_LIM_PISCES OPA_SRC LIM_SRC_2 NST_SRC TOP_SRC 10 ORCA2_LIM3 OPA_SRC LIM_SRC_3 NST_SRC 9 11 GYRE OPA_SRC 10 ORCA2_LIM3 OPA_SRC LIM_SRC_3 NST_SRC11 12 ORCA2_LIM OPA_SRC LIM_SRC_2 NST_SRC 12 ORCA2_OFF_PISCES OPA_SRC OFF_SRC TOP_SRC -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/ice.F90
r5341 r6455 253 253 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fhld !: heat flux from the lead used for bottom melting 254 254 255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: snow-ocean mass exchange over 1 time step [kg/m2]256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: snow precipitation on ice over 1 time step [kg/m2]257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: snow sublimation over 1 time step [kg/m2]258 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: ice-ocean mass exchange over 1 time step [kg/m2]260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: snow ice growth component of wfx_ice [kg/m2]261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: lateral ice growth component of wfx_ice [kg/m2]262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: bottom ice growth component of wfx_ice [kg/m2]263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: dynamical ice growth component of wfx_ice [kg /m2]264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: bottom melt component of wfx_ice [kg/m2]265 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: surface melt component of wfx_ice [kg/m2]266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: residual component of wfx_ice [kg/m2]267 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1]255 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_snw !: snow-ocean mass exchange [kg.m-2.s-1] 256 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_spr !: snow precipitation on ice [kg.m-2.s-1] 257 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sub !: snow/ice sublimation [kg.m-2.s-1] 258 259 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_ice !: ice-ocean mass exchange [kg.m-2.s-1] 260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sni !: snow ice growth component of wfx_ice [kg.m-2.s-1] 261 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_opw !: lateral ice growth component of wfx_ice [kg.m-2.s-1] 262 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bog !: bottom ice growth component of wfx_ice [kg.m-2.s-1] 263 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_dyn !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 264 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_bom !: bottom melt component of wfx_ice [kg.m-2.s-1] 265 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_sum !: surface melt component of wfx_ice [kg.m-2.s-1] 266 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_res !: residual component of wfx_ice [kg.m-2.s-1] 267 268 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_tot !: ice concentration tendency (total) [s-1] 269 269 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_thd !: ice concentration tendency (thermodynamics) [s-1] 270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_dyn !: ice concentration tendency (dynamics) [s-1]270 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: afx_dyn !: ice concentration tendency (dynamics) [s-1] 271 271 272 272 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_bog !: salt flux due to ice growth/melt [PSU/m2/s] … … 279 279 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_res !: residual salt flux due to correction of ice thickness [PSU/m2/s] 280 280 281 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth 282 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_in !: heat flux available for thermo transformations 291 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_out !: heat flux remaining at the end of thermo transformations 292 281 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sfx_sub !: salt flux due to ice sublimation 282 283 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bog !: total heat flux causing bottom ice growth [W.m-2] 284 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_bom !: total heat flux causing bottom ice melt [W.m-2] 285 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sum !: total heat flux causing surface ice melt [W.m-2] 286 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_opw !: total heat flux causing open water ice formation [W.m-2] 287 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dif !: total heat flux causing Temp change in the ice [W.m-2] 288 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_snw !: heat flux for snow melt [W.m-2] 289 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err !: heat flux error after heat diffusion [W.m-2] 290 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 291 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_err_rem !: heat flux error after heat remapping [W.m-2] 292 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_in !: heat flux available for thermo transformations [W.m-2] 293 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_out !: heat flux remaining at the end of thermo transformations [W.m-2] 294 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 295 293 296 ! heat flux associated with ice-atmosphere mass exchange 294 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation 295 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation 297 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_sub !: heat flux for sublimation [W.m-2] 298 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_spr !: heat flux of the snow precipitation [W.m-2] 296 299 297 300 ! heat flux associated with ice-ocean mass exchange 298 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (limthd_dh) 299 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me) 300 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness 301 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_thd !: ice-ocean heat flux from thermo processes (limthd_dh) [W.m-2] 302 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_dyn !: ice-ocean heat flux from mecanical processes (limitd_me) [W.m-2] 303 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hfx_res !: residual heat flux due to correction of ice thickness [W.m-2] 301 304 302 305 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ftr_ice !: transmitted solar radiation under ice 306 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rn_amax_2d !: maximum ice concentration 2d array 303 307 304 308 !!-------------------------------------------------------------------------- … … 372 376 INTEGER , PUBLIC :: nlay_i !: number of ice layers 373 377 INTEGER , PUBLIC :: nlay_s !: number of snow layers 374 CHARACTER(len= 32), PUBLIC :: cn_icerst_in !: suffix of ice restart name (input)378 CHARACTER(len=80), PUBLIC :: cn_icerst_in !: suffix of ice restart name (input) 375 379 CHARACTER(len=256), PUBLIC :: cn_icerst_indir !: ice restart input directory 376 CHARACTER(len= 32), PUBLIC :: cn_icerst_out !: suffix of ice restart name (output)380 CHARACTER(len=80), PUBLIC :: cn_icerst_out !: suffix of ice restart name (output) 377 381 CHARACTER(len=256), PUBLIC :: cn_icerst_outdir!: ice restart output directory 378 382 LOGICAL , PUBLIC :: ln_limdyn !: flag for ice dynamics (T) or not (F) 379 383 LOGICAL , PUBLIC :: ln_icectl !: flag for sea-ice points output (T) or not (F) 380 REAL(wp) , PUBLIC :: rn_amax !: maximum ice concentration 384 REAL(wp) , PUBLIC :: rn_amax_n !: maximum ice concentration Northern hemisphere 385 REAL(wp) , PUBLIC :: rn_amax_s !: maximum ice concentration Southern hemisphere 381 386 INTEGER , PUBLIC :: iiceprt !: debug i-point 382 387 INTEGER , PUBLIC :: jiceprt !: debug j-point … … 438 443 & afx_tot(jpi,jpj) , afx_thd(jpi,jpj), afx_dyn(jpi,jpj) , & 439 444 & fhtur (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead (jpi,jpj) , & 440 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , & 445 & rn_amax_2d(jpi,jpj), & 446 & sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) , & 441 447 & sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) , & 442 448 & hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) , & 443 & hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , 449 & hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) , & 444 450 & hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) , & 445 451 & hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) , & -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90
r5183 r6455 24 24 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 25 25 USE sbc_oce , ONLY : sfx ! Surface boundary condition: ocean fields 26 26 USE sbc_ice , ONLY : qevap_ice 27 27 28 IMPLICIT NONE 28 29 PRIVATE … … 184 185 ! salt flux 185 186 zfs_b = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 186 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) 187 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) & 187 188 & ) * e12t(:,:) * tmask(:,:,1) * zconv ) 188 189 … … 209 210 ! salt flux 210 211 zfs = glob_sum( ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + & 211 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) 212 & sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:) & 212 213 & ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 213 214 … … 256 257 ENDIF 257 258 IF ( zvmin < -epsi10 ) WRITE(numout,*) 'violation v_i<0 [m] (',cd_routine,') = ',zvmin 258 IF ( zamax > rn_amax+epsi10 .AND. cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 259 IF ( zamax > MAX( rn_amax_n, rn_amax_s ) + epsi10 .AND. & 260 & cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 259 261 WRITE(numout,*) 'violation a_i>amax (',cd_routine,') = ',zamax 260 262 ENDIF … … 286 288 #if ! defined key_bdy 287 289 ! heat flux 288 zhfx = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e12t * tmask(:,:,1) * zconv ) 290 zhfx = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - SUM( qevap_ice * a_i_b, dim=3 ) ) & 291 & * e12t * tmask(:,:,1) * zconv ) 289 292 ! salt flux 290 293 zsfx = glob_sum( ( sfx + diag_smvi ) * e12t * tmask(:,:,1) * zconv ) * rday -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90
r5215 r6455 56 56 real(wp) :: zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 57 57 real(wp) :: zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni, & 58 & zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn 58 & zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn, zbg_sfx_sub 59 59 real(wp) :: zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 60 60 real(wp) :: zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub … … 111 111 zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 112 112 zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 113 zbg_sfx_sub = ztmp * glob_sum( sfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) 113 114 114 115 ! Heat budget … … 189 190 CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom ) ! salt flux bottom melt - 190 191 CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum ) ! salt flux surface melt - 192 CALL iom_put( 'ibgsfxsub' , zbg_sfx_sub ) ! salt flux sublimation - 191 193 192 194 CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc ) ! Heat content variation in snow and ice [W] -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90
r5202 r6455 45 45 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: asum ! sum of total ice and open water area 46 46 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: aksum ! ratio of area removed to area ridged 47 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: athorn ! participation function; fraction of ridging/ 48 ! ! closing associated w/ category n 47 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: athorn ! participation function; fraction of ridging/closing associated w/ category n 49 48 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hrmin ! minimum ridge thickness 50 49 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hrmax ! maximum ridge thickness 51 50 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: hraft ! thickness of rafted ice 52 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: krdg ! mean ridge thickness/thickness of ridging ice51 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: krdg ! thickness of ridging ice / mean ridge thickness 53 52 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: aridge ! participating ice ridging 54 53 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: araft ! participating ice rafting 55 54 56 55 REAL(wp), PARAMETER :: krdgmin = 1.1_wp ! min ridge thickness multiplier 57 REAL(wp), PARAMETER :: kraft = 2.0_wp ! rafting multipliyer 58 REAL(wp), PARAMETER :: kamax = 1.0_wp ! max of ice area authorized (clem: scheme is not stable if kamax <= 0.99) 56 REAL(wp), PARAMETER :: kraft = 0.5_wp ! rafting multipliyer 59 57 60 58 REAL(wp) :: Cp ! 61 59 ! 62 !-----------------------------------------------------------------------63 ! Ridging diagnostic arrays for history files64 !-----------------------------------------------------------------------65 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dardg1dt ! rate of fractional area loss by ridging ice (1/s)66 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dardg2dt ! rate of fractional area gain by new ridges (1/s)67 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: dvirdgdt ! rate of ice volume ridged (m/s)68 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: opening ! rate of opening due to divergence/shear (1/s)69 60 ! 70 61 !!---------------------------------------------------------------------- … … 83 74 & asum (jpi,jpj) , athorn(jpi,jpj,0:jpl) , & 84 75 & aksum(jpi,jpj) , & 85 !86 76 & hrmin(jpi,jpj,jpl) , hraft(jpi,jpj,jpl) , aridge(jpi,jpj,jpl) , & 87 & hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , & 88 ! 89 !* Ridging diagnostic arrays for history files 90 & dardg1dt(jpi,jpj) , dardg2dt(jpi,jpj) , & 91 & dvirdgdt(jpi,jpj) , opening(jpi,jpj) , STAT=lim_itd_me_alloc ) 77 & hrmax(jpi,jpj,jpl) , krdg (jpi,jpj,jpl) , araft (jpi,jpj,jpl) , STAT=lim_itd_me_alloc ) 92 78 ! 93 79 IF( lim_itd_me_alloc /= 0 ) CALL ctl_warn( 'lim_itd_me_alloc: failed to allocate arrays' ) … … 132 118 REAL(wp), POINTER, DIMENSION(:,:) :: opning ! rate of opening due to divergence/shear 133 119 REAL(wp), POINTER, DIMENSION(:,:) :: closing_gross ! rate at which area removed, not counting area of new ridges 134 REAL(wp), POINTER, DIMENSION(:,:) :: msnow_mlt ! mass of snow added to ocean (kg m-2)135 REAL(wp), POINTER, DIMENSION(:,:) :: esnow_mlt ! energy needed to melt snow in ocean (J m-2)136 REAL(wp), POINTER, DIMENSION(:,:) :: vt_i_init, vt_i_final ! ice volume summed over categories137 120 ! 138 121 INTEGER, PARAMETER :: nitermax = 20 … … 142 125 IF( nn_timing == 1 ) CALL timing_start('limitd_me') 143 126 144 CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross , msnow_mlt, esnow_mlt, vt_i_init, vt_i_final)127 CALL wrk_alloc( jpi,jpj, closing_net, divu_adv, opning, closing_gross ) 145 128 146 129 IF(ln_ctl) THEN … … 154 137 IF( ln_limdiahsb ) CALL lim_cons_hsm(0, 'limitd_me', zvi_b, zsmv_b, zei_b, zfw_b, zfs_b, zft_b) 155 138 156 CALL lim_var_zapsmall157 CALL lim_var_glo2eqv ! equivalent variables, requested for rafting158 159 139 !-----------------------------------------------------------------------------! 160 140 ! 1) Thickness categories boundaries, ice / o.w. concentrations, init_ons … … 164 144 CALL lim_itd_me_ridgeprep ! prepare ridging 165 145 ! 166 IF( con_i) CALL lim_column_sum( jpl, v_i, vt_i_init ) ! conservation check167 146 168 147 DO jj = 1, jpj ! Initialize arrays. 169 148 DO ji = 1, jpi 170 msnow_mlt(ji,jj) = 0._wp171 esnow_mlt(ji,jj) = 0._wp172 dardg1dt (ji,jj) = 0._wp173 dardg2dt (ji,jj) = 0._wp174 dvirdgdt (ji,jj) = 0._wp175 opening (ji,jj) = 0._wp176 149 177 150 !-----------------------------------------------------------------------------! … … 204 177 ! If divu_adv < 0, make sure the closing rate is large enough 205 178 ! to give asum = 1.0 after ridging. 206 207 divu_adv(ji,jj) = ( kamax- asum(ji,jj) ) * r1_rdtice ! asum found in ridgeprep179 180 divu_adv(ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice ! asum found in ridgeprep 208 181 209 182 IF( divu_adv(ji,jj) < 0._wp ) closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) … … 224 197 DO WHILE ( iterate_ridging > 0 .AND. niter < nitermax ) 225 198 199 ! 3.2 closing_gross 200 !-----------------------------------------------------------------------------! 201 ! Based on the ITD of ridging and ridged ice, convert the net 202 ! closing rate to a gross closing rate. 203 ! NOTE: 0 < aksum <= 1 204 closing_gross(:,:) = closing_net(:,:) / aksum(:,:) 205 206 ! correction to closing rate and opening if closing rate is excessive 207 !--------------------------------------------------------------------- 208 ! Reduce the closing rate if more than 100% of the open water 209 ! would be removed. Reduce the opening rate proportionately. 226 210 DO jj = 1, jpj 227 211 DO ji = 1, jpi 228 229 ! 3.2 closing_gross 230 !-----------------------------------------------------------------------------! 231 ! Based on the ITD of ridging and ridged ice, convert the net 232 ! closing rate to a gross closing rate. 233 ! NOTE: 0 < aksum <= 1 234 closing_gross(ji,jj) = closing_net(ji,jj) / aksum(ji,jj) 235 236 ! correction to closing rate and opening if closing rate is excessive 237 !--------------------------------------------------------------------- 238 ! Reduce the closing rate if more than 100% of the open water 239 ! would be removed. Reduce the opening rate proportionately. 240 za = athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice 241 IF( za > epsi20 ) THEN 242 zfac = MIN( 1._wp, ato_i(ji,jj) / za ) 243 closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 244 opning (ji,jj) = opning (ji,jj) * zfac 212 za = ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice 213 IF( za < 0._wp .AND. za > - ato_i(ji,jj) ) THEN ! would lead to negative ato_i 214 zfac = - ato_i(ji,jj) / za 215 opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) - ato_i(ji,jj) * r1_rdtice 216 ELSEIF( za > 0._wp .AND. za > ( asum(ji,jj) - ato_i(ji,jj) ) ) THEN ! would lead to ato_i > asum 217 zfac = ( asum(ji,jj) - ato_i(ji,jj) ) / za 218 opning(ji,jj) = athorn(ji,jj,0) * closing_gross(ji,jj) + ( asum(ji,jj) - ato_i(ji,jj) ) * r1_rdtice 245 219 ENDIF 246 247 220 END DO 248 221 END DO … … 256 229 DO ji = 1, jpi 257 230 za = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 258 IF( za > epsi20) THEN259 zfac = MIN( 1._wp, a_i(ji,jj,jl) / za )231 IF( za > a_i(ji,jj,jl) ) THEN 232 zfac = a_i(ji,jj,jl) / za 260 233 closing_gross(ji,jj) = closing_gross(ji,jj) * zfac 261 opning (ji,jj) = opning (ji,jj) * zfac262 234 ENDIF 263 235 END DO … … 268 240 !-----------------------------------------------------------------------------! 269 241 270 CALL lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 271 242 CALL lim_itd_me_ridgeshift( opning, closing_gross ) 243 244 272 245 ! 3.4 Compute total area of ice plus open water after ridging. 273 246 !-----------------------------------------------------------------------------! 274 247 ! This is in general not equal to one because of divergence during transport 275 asum(:,:) = ato_i(:,:) 276 DO jl = 1, jpl 277 asum(:,:) = asum(:,:) + a_i(:,:,jl) 278 END DO 248 asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 279 249 280 250 ! 3.5 Do we keep on iterating ??? … … 284 254 285 255 iterate_ridging = 0 286 287 256 DO jj = 1, jpj 288 257 DO ji = 1, jpi 289 IF (ABS(asum(ji,jj) - kamax ) < epsi10) THEN258 IF( ABS( asum(ji,jj) - 1._wp ) < epsi10 ) THEN 290 259 closing_net(ji,jj) = 0._wp 291 260 opning (ji,jj) = 0._wp 292 261 ELSE 293 262 iterate_ridging = 1 294 divu_adv (ji,jj) = ( kamax- asum(ji,jj) ) * r1_rdtice263 divu_adv (ji,jj) = ( 1._wp - asum(ji,jj) ) * r1_rdtice 295 264 closing_net(ji,jj) = MAX( 0._wp, -divu_adv(ji,jj) ) 296 265 opning (ji,jj) = MAX( 0._wp, divu_adv(ji,jj) ) … … 309 278 310 279 IF( iterate_ridging == 1 ) THEN 280 CALL lim_itd_me_ridgeprep 311 281 IF( niter > nitermax ) THEN 312 282 WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 313 283 WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 314 284 ENDIF 315 CALL lim_itd_me_ridgeprep316 285 ENDIF 317 286 318 287 END DO !! on the do while over iter 319 320 !-----------------------------------------------------------------------------!321 ! 4) Ridging diagnostics322 !-----------------------------------------------------------------------------!323 ! Convert ridging rate diagnostics to correct units.324 ! Update fresh water and heat fluxes due to snow melt.325 DO jj = 1, jpj326 DO ji = 1, jpi327 328 dardg1dt(ji,jj) = dardg1dt(ji,jj) * r1_rdtice329 dardg2dt(ji,jj) = dardg2dt(ji,jj) * r1_rdtice330 dvirdgdt(ji,jj) = dvirdgdt(ji,jj) * r1_rdtice331 opening (ji,jj) = opening (ji,jj) * r1_rdtice332 333 !-----------------------------------------------------------------------------!334 ! 5) Heat, salt and freshwater fluxes335 !-----------------------------------------------------------------------------!336 wfx_snw(ji,jj) = wfx_snw(ji,jj) + msnow_mlt(ji,jj) * r1_rdtice ! fresh water source for ocean337 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + esnow_mlt(ji,jj) * r1_rdtice ! heat sink for ocean (<0, W.m-2)338 339 END DO340 END DO341 342 ! Check if there is a ridging error343 IF( lwp ) THEN344 DO jj = 1, jpj345 DO ji = 1, jpi346 IF( ABS( asum(ji,jj) - kamax) > epsi10 ) THEN ! there is a bug347 WRITE(numout,*) ' '348 WRITE(numout,*) ' ALERTE : Ridging error: total area = ', asum(ji,jj)349 WRITE(numout,*) ' limitd_me '350 WRITE(numout,*) ' POINT : ', ji, jj351 WRITE(numout,*) ' jpl, a_i, athorn '352 WRITE(numout,*) 0, ato_i(ji,jj), athorn(ji,jj,0)353 DO jl = 1, jpl354 WRITE(numout,*) jl, a_i(ji,jj,jl), athorn(ji,jj,jl)355 END DO356 ENDIF357 END DO358 END DO359 END IF360 361 ! Conservation check362 IF ( con_i ) THEN363 CALL lim_column_sum (jpl, v_i, vt_i_final)364 fieldid = ' v_i : limitd_me '365 CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)366 ENDIF367 288 368 289 CALL lim_var_agg( 1 ) … … 410 331 ENDIF ! ln_limdyn=.true. 411 332 ! 412 CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross , msnow_mlt, esnow_mlt, vt_i_init, vt_i_final)333 CALL wrk_dealloc( jpi, jpj, closing_net, divu_adv, opning, closing_gross ) 413 334 ! 414 335 IF( nn_timing == 1 ) CALL timing_stop('limitd_me') 415 336 END SUBROUTINE lim_itd_me 416 337 338 SUBROUTINE lim_itd_me_ridgeprep 339 !!---------------------------------------------------------------------! 340 !! *** ROUTINE lim_itd_me_ridgeprep *** 341 !! 342 !! ** Purpose : preparation for ridging and strength calculations 343 !! 344 !! ** Method : Compute the thickness distribution of the ice and open water 345 !! participating in ridging and of the resulting ridges. 346 !!---------------------------------------------------------------------! 347 INTEGER :: ji,jj, jl ! dummy loop indices 348 REAL(wp) :: Gstari, astari, hrmean, zdummy ! local scalar 349 REAL(wp), POINTER, DIMENSION(:,:,:) :: Gsum ! Gsum(n) = sum of areas in categories 0 to n 350 !------------------------------------------------------------------------------! 351 352 CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 353 354 Gstari = 1.0/rn_gstar 355 astari = 1.0/rn_astar 356 aksum(:,:) = 0.0 357 athorn(:,:,:) = 0.0 358 aridge(:,:,:) = 0.0 359 araft (:,:,:) = 0.0 360 361 ! Zero out categories with very small areas 362 CALL lim_var_zapsmall 363 364 ! Ice thickness needed for rafting 365 DO jl = 1, jpl 366 DO jj = 1, jpj 367 DO ji = 1, jpi 368 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) 369 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 370 END DO 371 END DO 372 END DO 373 374 !------------------------------------------------------------------------------! 375 ! 1) Participation function 376 !------------------------------------------------------------------------------! 377 378 ! Compute total area of ice plus open water. 379 ! This is in general not equal to one because of divergence during transport 380 asum(:,:) = ato_i(:,:) + SUM( a_i, dim=3 ) 381 382 ! Compute cumulative thickness distribution function 383 ! Compute the cumulative thickness distribution function Gsum, 384 ! where Gsum(n) is the fractional area in categories 0 to n. 385 ! initial value (in h = 0) equals open water area 386 Gsum(:,:,-1) = 0._wp 387 Gsum(:,:,0 ) = ato_i(:,:) 388 ! for each value of h, you have to add ice concentration then 389 DO jl = 1, jpl 390 Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl) 391 END DO 392 393 ! Normalize the cumulative distribution to 1 394 DO jl = 0, jpl 395 Gsum(:,:,jl) = Gsum(:,:,jl) / asum(:,:) 396 END DO 397 398 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn) 399 !-------------------------------------------------------------------------------------------------- 400 ! Compute the participation function athorn; this is analogous to 401 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975). 402 ! area lost from category n due to ridging/closing 403 ! athorn(n) = total area lost due to ridging/closing 404 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar). 405 ! 406 ! The expressions for athorn are found by integrating b(h)g(h) between 407 ! the category boundaries. 408 ! athorn is always >= 0 and SUM(athorn(0:jpl))=1 409 !----------------------------------------------------------------- 410 411 IF( nn_partfun == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975) 412 DO jl = 0, jpl 413 DO jj = 1, jpj 414 DO ji = 1, jpi 415 IF ( Gsum(ji,jj,jl) < rn_gstar ) THEN 416 athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * & 417 & ( 2._wp - ( Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari ) 418 ELSEIF( Gsum(ji,jj,jl-1) < rn_gstar ) THEN 419 athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) * & 420 & ( 2._wp - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari ) 421 ELSE 422 athorn(ji,jj,jl) = 0._wp 423 ENDIF 424 END DO 425 END DO 426 END DO 427 428 ELSE !--- Exponential, more stable formulation (Lipscomb et al, 2007) 429 ! 430 zdummy = 1._wp / ( 1._wp - EXP(-astari) ) ! precompute exponential terms using Gsum as a work array 431 DO jl = -1, jpl 432 Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 433 END DO 434 DO jl = 0, jpl 435 athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 436 END DO 437 ! 438 ENDIF 439 440 IF( ln_rafting ) THEN ! Ridging and rafting ice participation functions 441 ! 442 DO jl = 1, jpl 443 DO jj = 1, jpj 444 DO ji = 1, jpi 445 zdummy = TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) 446 aridge(ji,jj,jl) = ( 1._wp + zdummy ) * 0.5_wp * athorn(ji,jj,jl) 447 araft (ji,jj,jl) = ( 1._wp - zdummy ) * 0.5_wp * athorn(ji,jj,jl) 448 END DO 449 END DO 450 END DO 451 452 ELSE 453 ! 454 DO jl = 1, jpl 455 aridge(:,:,jl) = athorn(:,:,jl) 456 END DO 457 ! 458 ENDIF 459 460 !----------------------------------------------------------------- 461 ! 2) Transfer function 462 !----------------------------------------------------------------- 463 ! Compute max and min ridged ice thickness for each ridging category. 464 ! Assume ridged ice is uniformly distributed between hrmin and hrmax. 465 ! 466 ! This parameterization is a modified version of Hibler (1980). 467 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5) 468 ! and for very thick ridging ice must be >= krdgmin*hi 469 ! 470 ! The minimum ridging thickness, hrmin, is equal to 2*hi 471 ! (i.e., rafting) and for very thick ridging ice is 472 ! constrained by hrmin <= (hrmean + hi)/2. 473 ! 474 ! The maximum ridging thickness, hrmax, is determined by 475 ! hrmean and hrmin. 476 ! 477 ! These modifications have the effect of reducing the ice strength 478 ! (relative to the Hibler formulation) when very thick ice is 479 ! ridging. 480 ! 481 ! aksum = net area removed/ total area removed 482 ! where total area removed = area of ice that ridges 483 ! net area removed = total area removed - area of new ridges 484 !----------------------------------------------------------------- 485 486 aksum(:,:) = athorn(:,:,0) 487 ! Transfer function 488 DO jl = 1, jpl !all categories have a specific transfer function 489 DO jj = 1, jpj 490 DO ji = 1, jpi 491 492 IF( athorn(ji,jj,jl) > 0._wp ) THEN 493 hrmean = MAX( SQRT( rn_hstar * ht_i(ji,jj,jl) ), ht_i(ji,jj,jl) * krdgmin ) 494 hrmin(ji,jj,jl) = MIN( 2._wp * ht_i(ji,jj,jl), 0.5_wp * ( hrmean + ht_i(ji,jj,jl) ) ) 495 hrmax(ji,jj,jl) = 2._wp * hrmean - hrmin(ji,jj,jl) 496 hraft(ji,jj,jl) = ht_i(ji,jj,jl) / kraft 497 krdg(ji,jj,jl) = ht_i(ji,jj,jl) / MAX( hrmean, epsi20 ) 498 499 ! Normalization factor : aksum, ensures mass conservation 500 aksum(ji,jj) = aksum(ji,jj) + aridge(ji,jj,jl) * ( 1._wp - krdg(ji,jj,jl) ) & 501 & + araft (ji,jj,jl) * ( 1._wp - kraft ) 502 503 ELSE 504 hrmin(ji,jj,jl) = 0._wp 505 hrmax(ji,jj,jl) = 0._wp 506 hraft(ji,jj,jl) = 0._wp 507 krdg (ji,jj,jl) = 1._wp 508 ENDIF 509 510 END DO 511 END DO 512 END DO 513 ! 514 CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 ) 515 ! 516 END SUBROUTINE lim_itd_me_ridgeprep 517 518 519 SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross ) 520 !!---------------------------------------------------------------------- 521 !! *** ROUTINE lim_itd_me_icestrength *** 522 !! 523 !! ** Purpose : shift ridging ice among thickness categories of ice thickness 524 !! 525 !! ** Method : Remove area, volume, and energy from each ridging category 526 !! and add to thicker ice categories. 527 !!---------------------------------------------------------------------- 528 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: opning ! rate of opening due to divergence/shear 529 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: closing_gross ! rate at which area removed, excluding area of new ridges 530 ! 531 CHARACTER (len=80) :: fieldid ! field identifier 532 ! 533 INTEGER :: ji, jj, jl, jl1, jl2, jk ! dummy loop indices 534 INTEGER :: ij ! horizontal index, combines i and j loops 535 INTEGER :: icells ! number of cells with a_i > puny 536 REAL(wp) :: hL, hR, farea ! left and right limits of integration 537 538 INTEGER , POINTER, DIMENSION(:) :: indxi, indxj ! compressed indices 539 REAL(wp), POINTER, DIMENSION(:) :: zswitch, fvol ! new ridge volume going to n2 540 541 REAL(wp), POINTER, DIMENSION(:) :: afrac ! fraction of category area ridged 542 REAL(wp), POINTER, DIMENSION(:) :: ardg1 , ardg2 ! area of ice ridged & new ridges 543 REAL(wp), POINTER, DIMENSION(:) :: vsrdg , esrdg ! snow volume & energy of ridging ice 544 REAL(wp), POINTER, DIMENSION(:) :: dhr , dhr2 ! hrmax - hrmin & hrmax^2 - hrmin^2 545 546 REAL(wp), POINTER, DIMENSION(:) :: vrdg1 ! volume of ice ridged 547 REAL(wp), POINTER, DIMENSION(:) :: vrdg2 ! volume of new ridges 548 REAL(wp), POINTER, DIMENSION(:) :: vsw ! volume of seawater trapped into ridges 549 REAL(wp), POINTER, DIMENSION(:) :: srdg1 ! sal*volume of ice ridged 550 REAL(wp), POINTER, DIMENSION(:) :: srdg2 ! sal*volume of new ridges 551 REAL(wp), POINTER, DIMENSION(:) :: smsw ! sal*volume of water trapped into ridges 552 REAL(wp), POINTER, DIMENSION(:) :: oirdg1, oirdg2 ! ice age of ice ridged 553 554 REAL(wp), POINTER, DIMENSION(:) :: afrft ! fraction of category area rafted 555 REAL(wp), POINTER, DIMENSION(:) :: arft1 , arft2 ! area of ice rafted and new rafted zone 556 REAL(wp), POINTER, DIMENSION(:) :: virft , vsrft ! ice & snow volume of rafting ice 557 REAL(wp), POINTER, DIMENSION(:) :: esrft , smrft ! snow energy & salinity of rafting ice 558 REAL(wp), POINTER, DIMENSION(:) :: oirft1, oirft2 ! ice age of ice rafted 559 560 REAL(wp), POINTER, DIMENSION(:,:) :: eirft ! ice energy of rafting ice 561 REAL(wp), POINTER, DIMENSION(:,:) :: erdg1 ! enth*volume of ice ridged 562 REAL(wp), POINTER, DIMENSION(:,:) :: erdg2 ! enth*volume of new ridges 563 REAL(wp), POINTER, DIMENSION(:,:) :: ersw ! enth of water trapped into ridges 564 !!---------------------------------------------------------------------- 565 566 CALL wrk_alloc( jpij, indxi, indxj ) 567 CALL wrk_alloc( jpij, zswitch, fvol ) 568 CALL wrk_alloc( jpij, afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 569 CALL wrk_alloc( jpij, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 570 CALL wrk_alloc( jpij, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 571 CALL wrk_alloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 572 573 !------------------------------------------------------------------------------- 574 ! 1) Compute change in open water area due to closing and opening. 575 !------------------------------------------------------------------------------- 576 DO jj = 1, jpj 577 DO ji = 1, jpi 578 ato_i(ji,jj) = MAX( 0._wp, ato_i(ji,jj) + & 579 & ( opning(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) ) * rdt_ice ) 580 END DO 581 END DO 582 583 !----------------------------------------------------------------- 584 ! 3) Pump everything from ice which is being ridged / rafted 585 !----------------------------------------------------------------- 586 ! Compute the area, volume, and energy of ice ridging in each 587 ! category, along with the area of the resulting ridge. 588 589 DO jl1 = 1, jpl !jl1 describes the ridging category 590 591 !------------------------------------------------ 592 ! 3.1) Identify grid cells with nonzero ridging 593 !------------------------------------------------ 594 icells = 0 595 DO jj = 1, jpj 596 DO ji = 1, jpi 597 IF( athorn(ji,jj,jl1) > 0._wp .AND. closing_gross(ji,jj) > 0._wp ) THEN 598 icells = icells + 1 599 indxi(icells) = ji 600 indxj(icells) = jj 601 ENDIF 602 END DO 603 END DO 604 605 DO ij = 1, icells 606 ji = indxi(ij) ; jj = indxj(ij) 607 608 !-------------------------------------------------------------------- 609 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2) 610 !-------------------------------------------------------------------- 611 ardg1(ij) = aridge(ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 612 arft1(ij) = araft (ji,jj,jl1) * closing_gross(ji,jj) * rdt_ice 613 614 !--------------------------------------------------------------- 615 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1 616 !--------------------------------------------------------------- 617 afrac(ij) = ardg1(ij) / a_i(ji,jj,jl1) !ridging 618 afrft(ij) = arft1(ij) / a_i(ji,jj,jl1) !rafting 619 ardg2(ij) = ardg1(ij) * krdg(ji,jj,jl1) 620 arft2(ij) = arft1(ij) * kraft 621 622 !-------------------------------------------------------------------------- 623 ! 3.4) Subtract area, volume, and energy from ridging 624 ! / rafting category n1. 625 !-------------------------------------------------------------------------- 626 vrdg1(ij) = v_i(ji,jj,jl1) * afrac(ij) 627 vrdg2(ij) = vrdg1(ij) * ( 1. + rn_por_rdg ) 628 vsw (ij) = vrdg1(ij) * rn_por_rdg 629 630 vsrdg (ij) = v_s (ji,jj, jl1) * afrac(ij) 631 esrdg (ij) = e_s (ji,jj,1,jl1) * afrac(ij) 632 srdg1 (ij) = smv_i(ji,jj, jl1) * afrac(ij) 633 oirdg1(ij) = oa_i (ji,jj, jl1) * afrac(ij) 634 oirdg2(ij) = oa_i (ji,jj, jl1) * afrac(ij) * krdg(ji,jj,jl1) 635 636 ! rafting volumes, heat contents ... 637 virft (ij) = v_i (ji,jj, jl1) * afrft(ij) 638 vsrft (ij) = v_s (ji,jj, jl1) * afrft(ij) 639 esrft (ij) = e_s (ji,jj,1,jl1) * afrft(ij) 640 smrft (ij) = smv_i(ji,jj, jl1) * afrft(ij) 641 oirft1(ij) = oa_i (ji,jj, jl1) * afrft(ij) 642 oirft2(ij) = oa_i (ji,jj, jl1) * afrft(ij) * kraft 643 644 !----------------------------------------------------------------- 645 ! 3.5) Compute properties of new ridges 646 !----------------------------------------------------------------- 647 smsw(ij) = vsw(ij) * sss_m(ji,jj) ! salt content of seawater frozen in voids 648 srdg2(ij) = srdg1(ij) + smsw(ij) ! salt content of new ridge 649 650 sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ij) * rhoic * r1_rdtice 651 wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ij) * rhoic * r1_rdtice ! increase in ice volume due to seawater frozen in voids 652 653 !------------------------------------------ 654 ! 3.7 Put the snow somewhere in the ocean 655 !------------------------------------------ 656 ! Place part of the snow lost by ridging into the ocean. 657 ! Note that esrdg > 0; the ocean must cool to melt snow. 658 ! If the ocean temp = Tf already, new ice must grow. 659 ! During the next time step, thermo_rates will determine whether 660 ! the ocean cools or new ice grows. 661 wfx_snw(ji,jj) = wfx_snw(ji,jj) + ( rhosn * vsrdg(ij) * ( 1._wp - rn_fsnowrdg ) & 662 & + rhosn * vsrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice ! fresh water source for ocean 663 664 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ( - esrdg(ij) * ( 1._wp - rn_fsnowrdg ) & 665 & - esrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice ! heat sink for ocean (<0, W.m-2) 666 667 !----------------------------------------------------------------- 668 ! 3.8 Compute quantities used to apportion ice among categories 669 ! in the n2 loop below 670 !----------------------------------------------------------------- 671 dhr (ij) = 1._wp / ( hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) ) 672 dhr2(ij) = 1._wp / ( hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) ) 673 674 675 ! update jl1 (removing ridged/rafted area) 676 a_i (ji,jj, jl1) = a_i (ji,jj, jl1) - ardg1 (ij) - arft1 (ij) 677 v_i (ji,jj, jl1) = v_i (ji,jj, jl1) - vrdg1 (ij) - virft (ij) 678 v_s (ji,jj, jl1) = v_s (ji,jj, jl1) - vsrdg (ij) - vsrft (ij) 679 e_s (ji,jj,1,jl1) = e_s (ji,jj,1,jl1) - esrdg (ij) - esrft (ij) 680 smv_i(ji,jj, jl1) = smv_i(ji,jj, jl1) - srdg1 (ij) - smrft (ij) 681 oa_i (ji,jj, jl1) = oa_i (ji,jj, jl1) - oirdg1(ij) - oirft1(ij) 682 683 END DO 684 685 !-------------------------------------------------------------------- 686 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and 687 ! compute ridged ice enthalpy 688 !-------------------------------------------------------------------- 689 DO jk = 1, nlay_i 690 DO ij = 1, icells 691 ji = indxi(ij) ; jj = indxj(ij) 692 ! heat content of ridged ice 693 erdg1(ij,jk) = e_i(ji,jj,jk,jl1) * afrac(ij) 694 eirft(ij,jk) = e_i(ji,jj,jk,jl1) * afrft(ij) 695 696 ! enthalpy of the trapped seawater (J/m2, >0) 697 ! clem: if sst>0, then ersw <0 (is that possible?) 698 ersw(ij,jk) = - rhoic * vsw(ij) * rcp * sst_m(ji,jj) * r1_nlay_i 699 700 ! heat flux to the ocean 701 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ij,jk) * r1_rdtice ! > 0 [W.m-2] ocean->ice flux 702 703 ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean 704 erdg2(ij,jk) = erdg1(ij,jk) + ersw(ij,jk) 705 706 ! update jl1 707 e_i (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ij,jk) - eirft(ij,jk) 708 709 END DO 710 END DO 711 712 !------------------------------------------------------------------------------- 713 ! 4) Add area, volume, and energy of new ridge to each category jl2 714 !------------------------------------------------------------------------------- 715 DO jl2 = 1, jpl 716 ! over categories to which ridged/rafted ice is transferred 717 DO ij = 1, icells 718 ji = indxi(ij) ; jj = indxj(ij) 719 720 ! Compute the fraction of ridged ice area and volume going to thickness category jl2. 721 IF( hrmin(ji,jj,jl1) <= hi_max(jl2) .AND. hrmax(ji,jj,jl1) > hi_max(jl2-1) ) THEN 722 hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) ) 723 hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2) ) 724 farea = ( hR - hL ) * dhr(ij) 725 fvol(ij) = ( hR * hR - hL * hL ) * dhr2(ij) 726 ELSE 727 farea = 0._wp 728 fvol(ij) = 0._wp 729 ENDIF 730 731 ! Compute the fraction of rafted ice area and volume going to thickness category jl2 732 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN 733 zswitch(ij) = 1._wp 734 ELSE 735 zswitch(ij) = 0._wp 736 ENDIF 737 738 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + ( ardg2 (ij) * farea + arft2 (ij) * zswitch(ij) ) 739 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + ( oirdg2(ij) * farea + oirft2(ij) * zswitch(ij) ) 740 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + ( vrdg2 (ij) * fvol(ij) + virft (ij) * zswitch(ij) ) 741 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + ( srdg2 (ij) * fvol(ij) + smrft (ij) * zswitch(ij) ) 742 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + ( vsrdg (ij) * rn_fsnowrdg * fvol(ij) + & 743 & vsrft (ij) * rn_fsnowrft * zswitch(ij) ) 744 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + ( esrdg (ij) * rn_fsnowrdg * fvol(ij) + & 745 & esrft (ij) * rn_fsnowrft * zswitch(ij) ) 746 747 END DO 748 749 ! Transfer ice energy to category jl2 by ridging 750 DO jk = 1, nlay_i 751 DO ij = 1, icells 752 ji = indxi(ij) ; jj = indxj(ij) 753 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + erdg2(ij,jk) * fvol(ij) + eirft(ij,jk) * zswitch(ij) 754 END DO 755 END DO 756 ! 757 END DO ! jl2 758 759 END DO ! jl1 (deforming categories) 760 761 ! 762 CALL wrk_dealloc( jpij, indxi, indxj ) 763 CALL wrk_dealloc( jpij, zswitch, fvol ) 764 CALL wrk_dealloc( jpij, afrac, ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 ) 765 CALL wrk_dealloc( jpij, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 ) 766 CALL wrk_dealloc( jpij, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 ) 767 CALL wrk_dealloc( jpij,nlay_i, eirft, erdg1, erdg2, ersw ) 768 ! 769 END SUBROUTINE lim_itd_me_ridgeshift 417 770 418 771 SUBROUTINE lim_itd_me_icestrength( kstrngth ) … … 434 787 INTEGER :: ksmooth ! smoothing the resistance to deformation 435 788 INTEGER :: numts_rm ! number of time steps for the P smoothing 436 REAL(wp) :: z hi, zp, z1_3! local scalars789 REAL(wp) :: zp, z1_3 ! local scalars 437 790 REAL(wp), POINTER, DIMENSION(:,:) :: zworka ! temporary array used here 438 791 !!---------------------------------------------------------------------- … … 459 812 DO ji = 1, jpi 460 813 ! 461 IF( a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0._wp ) THEN 462 zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 814 IF( athorn(ji,jj,jl) > 0._wp ) THEN 463 815 !---------------------------- 464 816 ! PE loss from deforming ice 465 817 !---------------------------- 466 strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * zhi * zhi818 strength(ji,jj) = strength(ji,jj) - athorn(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 467 819 468 820 !-------------------------- 469 821 ! PE gain from rafting ice 470 822 !-------------------------- 471 strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * zhi * zhi823 strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * ht_i(ji,jj,jl) * ht_i(ji,jj,jl) 472 824 473 825 !---------------------------- 474 826 ! PE gain from ridging ice 475 827 !---------------------------- 476 strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) / krdg(ji,jj,jl) & 477 * z1_3 * ( hrmax(ji,jj,jl)**2 + hrmin(ji,jj,jl)**2 + hrmax(ji,jj,jl) * hrmin(ji,jj,jl) ) 828 strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl) * krdg(ji,jj,jl) * z1_3 * & 829 & ( hrmax(ji,jj,jl) * hrmax(ji,jj,jl) + & 830 & hrmin(ji,jj,jl) * hrmin(ji,jj,jl) + & 831 & hrmax(ji,jj,jl) * hrmin(ji,jj,jl) ) 478 832 !!(a**3-b**3)/(a-b) = a*a+ab+b*b 479 833 ENDIF … … 497 851 ! 498 852 ENDIF ! kstrngth 499 500 853 ! 501 854 !------------------------------------------------------------------------------! … … 503 856 !------------------------------------------------------------------------------! 504 857 ! CAN BE REMOVED 505 !506 858 IF( ln_icestr_bvf ) THEN 507 508 859 DO jj = 1, jpj 509 860 DO ji = 1, jpi … … 511 862 END DO 512 863 END DO 513 514 864 ENDIF 515 516 865 ! 517 866 !------------------------------------------------------------------------------! … … 558 907 IF ( ksmooth == 2 ) THEN 559 908 560 561 909 CALL lbc_lnk( strength, 'T', 1. ) 562 910 … … 565 913 IF ( ( asum(ji,jj) - ato_i(ji,jj) ) > 0._wp) THEN 566 914 numts_rm = 1 ! number of time steps for the running mean 567 IF ( strp1(ji,jj) > 0. 0) numts_rm = numts_rm + 1568 IF ( strp2(ji,jj) > 0. 0) numts_rm = numts_rm + 1915 IF ( strp1(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 916 IF ( strp2(ji,jj) > 0._wp ) numts_rm = numts_rm + 1 569 917 zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 570 918 strp2(ji,jj) = strp1(ji,jj) … … 583 931 ! 584 932 END SUBROUTINE lim_itd_me_icestrength 585 586 587 SUBROUTINE lim_itd_me_ridgeprep588 !!---------------------------------------------------------------------!589 !! *** ROUTINE lim_itd_me_ridgeprep ***590 !!591 !! ** Purpose : preparation for ridging and strength calculations592 !!593 !! ** Method : Compute the thickness distribution of the ice and open water594 !! participating in ridging and of the resulting ridges.595 !!---------------------------------------------------------------------!596 INTEGER :: ji,jj, jl ! dummy loop indices597 REAL(wp) :: Gstari, astari, zhi, hrmean, zdummy ! local scalar598 REAL(wp), POINTER, DIMENSION(:,:) :: zworka ! temporary array used here599 REAL(wp), POINTER, DIMENSION(:,:,:) :: Gsum ! Gsum(n) = sum of areas in categories 0 to n600 !------------------------------------------------------------------------------!601 602 CALL wrk_alloc( jpi,jpj, zworka )603 CALL wrk_alloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 )604 605 Gstari = 1.0/rn_gstar606 astari = 1.0/rn_astar607 aksum(:,:) = 0.0608 athorn(:,:,:) = 0.0609 aridge(:,:,:) = 0.0610 araft (:,:,:) = 0.0611 hrmin(:,:,:) = 0.0612 hrmax(:,:,:) = 0.0613 hraft(:,:,:) = 0.0614 krdg (:,:,:) = 1.0615 616 ! ! Zero out categories with very small areas617 CALL lim_var_zapsmall618 619 !------------------------------------------------------------------------------!620 ! 1) Participation function621 !------------------------------------------------------------------------------!622 623 ! Compute total area of ice plus open water.624 ! This is in general not equal to one because of divergence during transport625 asum(:,:) = ato_i(:,:)626 DO jl = 1, jpl627 asum(:,:) = asum(:,:) + a_i(:,:,jl)628 END DO629 630 ! Compute cumulative thickness distribution function631 ! Compute the cumulative thickness distribution function Gsum,632 ! where Gsum(n) is the fractional area in categories 0 to n.633 ! initial value (in h = 0) equals open water area634 635 Gsum(:,:,-1) = 0._wp636 Gsum(:,:,0 ) = ato_i(:,:)637 638 ! for each value of h, you have to add ice concentration then639 DO jl = 1, jpl640 Gsum(:,:,jl) = Gsum(:,:,jl-1) + a_i(:,:,jl)641 END DO642 643 ! Normalize the cumulative distribution to 1644 zworka(:,:) = 1._wp / Gsum(:,:,jpl)645 DO jl = 0, jpl646 Gsum(:,:,jl) = Gsum(:,:,jl) * zworka(:,:)647 END DO648 649 ! 1.3 Compute participation function a(h) = b(h).g(h) (athorn)650 !--------------------------------------------------------------------------------------------------651 ! Compute the participation function athorn; this is analogous to652 ! a(h) = b(h)g(h) as defined in Thorndike et al. (1975).653 ! area lost from category n due to ridging/closing654 ! athorn(n) = total area lost due to ridging/closing655 ! assume b(h) = (2/Gstar) * (1 - G(h)/Gstar).656 !657 ! The expressions for athorn are found by integrating b(h)g(h) between658 ! the category boundaries.659 !-----------------------------------------------------------------660 661 IF( nn_partfun == 0 ) THEN !--- Linear formulation (Thorndike et al., 1975)662 DO jl = 0, jpl663 DO jj = 1, jpj664 DO ji = 1, jpi665 IF( Gsum(ji,jj,jl) < rn_gstar) THEN666 athorn(ji,jj,jl) = Gstari * ( Gsum(ji,jj,jl) - Gsum(ji,jj,jl-1) ) * &667 & ( 2.0 - (Gsum(ji,jj,jl-1) + Gsum(ji,jj,jl) ) * Gstari )668 ELSEIF (Gsum(ji,jj,jl-1) < rn_gstar) THEN669 athorn(ji,jj,jl) = Gstari * ( rn_gstar - Gsum(ji,jj,jl-1) ) * &670 & ( 2.0 - ( Gsum(ji,jj,jl-1) + rn_gstar ) * Gstari )671 ELSE672 athorn(ji,jj,jl) = 0.0673 ENDIF674 END DO675 END DO676 END DO677 678 ELSE !--- Exponential, more stable formulation (Lipscomb et al, 2007)679 !680 zdummy = 1._wp / ( 1._wp - EXP(-astari) ) ! precompute exponential terms using Gsum as a work array681 DO jl = -1, jpl682 Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy683 END DO684 DO jl = 0, jpl685 athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl)686 END DO687 !688 ENDIF689 690 IF( ln_rafting ) THEN ! Ridging and rafting ice participation functions691 !692 DO jl = 1, jpl693 DO jj = 1, jpj694 DO ji = 1, jpi695 IF ( athorn(ji,jj,jl) > 0._wp ) THEN696 !!gm TANH( -X ) = - TANH( X ) so can be computed only 1 time....697 aridge(ji,jj,jl) = ( TANH ( rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl)698 araft (ji,jj,jl) = ( TANH ( -rn_craft * ( ht_i(ji,jj,jl) - rn_hraft ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl)699 IF ( araft(ji,jj,jl) < epsi06 ) araft(ji,jj,jl) = 0._wp700 aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 )701 ENDIF702 END DO703 END DO704 END DO705 706 ELSE707 !708 DO jl = 1, jpl709 aridge(:,:,jl) = athorn(:,:,jl)710 END DO711 !712 ENDIF713 714 IF( ln_rafting ) THEN715 716 IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) > epsi10 .AND. lwp ) THEN717 DO jl = 1, jpl718 DO jj = 1, jpj719 DO ji = 1, jpi720 IF ( aridge(ji,jj,jl) + araft(ji,jj,jl) - athorn(ji,jj,jl) > epsi10 ) THEN721 WRITE(numout,*) ' ALERTE 96 : wrong participation function ... '722 WRITE(numout,*) ' ji, jj, jl : ', ji, jj, jl723 WRITE(numout,*) ' lat, lon : ', gphit(ji,jj), glamt(ji,jj)724 WRITE(numout,*) ' aridge : ', aridge(ji,jj,1:jpl)725 WRITE(numout,*) ' araft : ', araft(ji,jj,1:jpl)726 WRITE(numout,*) ' athorn : ', athorn(ji,jj,1:jpl)727 ENDIF728 END DO729 END DO730 END DO731 ENDIF732 733 ENDIF734 735 !-----------------------------------------------------------------736 ! 2) Transfer function737 !-----------------------------------------------------------------738 ! Compute max and min ridged ice thickness for each ridging category.739 ! Assume ridged ice is uniformly distributed between hrmin and hrmax.740 !741 ! This parameterization is a modified version of Hibler (1980).742 ! The mean ridging thickness, hrmean, is proportional to hi^(0.5)743 ! and for very thick ridging ice must be >= krdgmin*hi744 !745 ! The minimum ridging thickness, hrmin, is equal to 2*hi746 ! (i.e., rafting) and for very thick ridging ice is747 ! constrained by hrmin <= (hrmean + hi)/2.748 !749 ! The maximum ridging thickness, hrmax, is determined by750 ! hrmean and hrmin.751 !752 ! These modifications have the effect of reducing the ice strength753 ! (relative to the Hibler formulation) when very thick ice is754 ! ridging.755 !756 ! aksum = net area removed/ total area removed757 ! where total area removed = area of ice that ridges758 ! net area removed = total area removed - area of new ridges759 !-----------------------------------------------------------------760 761 ! Transfer function762 DO jl = 1, jpl !all categories have a specific transfer function763 DO jj = 1, jpj764 DO ji = 1, jpi765 766 IF (a_i(ji,jj,jl) > epsi10 .AND. athorn(ji,jj,jl) > 0.0 ) THEN767 zhi = v_i(ji,jj,jl) / a_i(ji,jj,jl)768 hrmean = MAX(SQRT(rn_hstar*zhi), zhi*krdgmin)769 hrmin(ji,jj,jl) = MIN(2.0*zhi, 0.5*(hrmean + zhi))770 hrmax(ji,jj,jl) = 2.0*hrmean - hrmin(ji,jj,jl)771 hraft(ji,jj,jl) = kraft*zhi772 krdg(ji,jj,jl) = hrmean / zhi773 ELSE774 hraft(ji,jj,jl) = 0.0775 hrmin(ji,jj,jl) = 0.0776 hrmax(ji,jj,jl) = 0.0777 krdg (ji,jj,jl) = 1.0778 ENDIF779 780 END DO781 END DO782 END DO783 784 ! Normalization factor : aksum, ensures mass conservation785 aksum(:,:) = athorn(:,:,0)786 DO jl = 1, jpl787 aksum(:,:) = aksum(:,:) + aridge(:,:,jl) * ( 1._wp - 1._wp / krdg(:,:,jl) ) &788 & + araft (:,:,jl) * ( 1._wp - 1._wp / kraft )789 END DO790 !791 CALL wrk_dealloc( jpi,jpj, zworka )792 CALL wrk_dealloc( jpi,jpj,jpl+2, Gsum, kkstart = -1 )793 !794 END SUBROUTINE lim_itd_me_ridgeprep795 796 797 SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt )798 !!----------------------------------------------------------------------799 !! *** ROUTINE lim_itd_me_icestrength ***800 !!801 !! ** Purpose : shift ridging ice among thickness categories of ice thickness802 !!803 !! ** Method : Remove area, volume, and energy from each ridging category804 !! and add to thicker ice categories.805 !!----------------------------------------------------------------------806 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: opning ! rate of opening due to divergence/shear807 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: closing_gross ! rate at which area removed, excluding area of new ridges808 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: msnow_mlt ! mass of snow added to ocean (kg m-2)809 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: esnow_mlt ! energy needed to melt snow in ocean (J m-2)810 !811 CHARACTER (len=80) :: fieldid ! field identifier812 LOGICAL, PARAMETER :: l_conservation_check = .true. ! if true, check conservation (useful for debugging)813 !814 INTEGER :: ji, jj, jl, jl1, jl2, jk ! dummy loop indices815 INTEGER :: ij ! horizontal index, combines i and j loops816 INTEGER :: icells ! number of cells with aicen > puny817 REAL(wp) :: hL, hR, farea, ztmelts ! left and right limits of integration818 819 INTEGER , POINTER, DIMENSION(:) :: indxi, indxj ! compressed indices820 821 REAL(wp), POINTER, DIMENSION(:,:) :: vice_init, vice_final ! ice volume summed over categories822 REAL(wp), POINTER, DIMENSION(:,:) :: eice_init, eice_final ! ice energy summed over layers823 824 REAL(wp), POINTER, DIMENSION(:,:,:) :: aicen_init, vicen_init ! ice area & volume before ridging825 REAL(wp), POINTER, DIMENSION(:,:,:) :: vsnwn_init, esnwn_init ! snow volume & energy before ridging826 REAL(wp), POINTER, DIMENSION(:,:,:) :: smv_i_init, oa_i_init ! ice salinity & age before ridging827 828 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: eicen_init ! ice energy before ridging829 830 REAL(wp), POINTER, DIMENSION(:,:) :: afrac , fvol ! fraction of category area ridged & new ridge volume going to n2831 REAL(wp), POINTER, DIMENSION(:,:) :: ardg1 , ardg2 ! area of ice ridged & new ridges832 REAL(wp), POINTER, DIMENSION(:,:) :: vsrdg , esrdg ! snow volume & energy of ridging ice833 REAL(wp), POINTER, DIMENSION(:,:) :: dhr , dhr2 ! hrmax - hrmin & hrmax^2 - hrmin^2834 835 REAL(wp), POINTER, DIMENSION(:,:) :: vrdg1 ! volume of ice ridged836 REAL(wp), POINTER, DIMENSION(:,:) :: vrdg2 ! volume of new ridges837 REAL(wp), POINTER, DIMENSION(:,:) :: vsw ! volume of seawater trapped into ridges838 REAL(wp), POINTER, DIMENSION(:,:) :: srdg1 ! sal*volume of ice ridged839 REAL(wp), POINTER, DIMENSION(:,:) :: srdg2 ! sal*volume of new ridges840 REAL(wp), POINTER, DIMENSION(:,:) :: smsw ! sal*volume of water trapped into ridges841 REAL(wp), POINTER, DIMENSION(:,:) :: oirdg1, oirdg2 ! ice age of ice ridged842 843 REAL(wp), POINTER, DIMENSION(:,:) :: afrft ! fraction of category area rafted844 REAL(wp), POINTER, DIMENSION(:,:) :: arft1 , arft2 ! area of ice rafted and new rafted zone845 REAL(wp), POINTER, DIMENSION(:,:) :: virft , vsrft ! ice & snow volume of rafting ice846 REAL(wp), POINTER, DIMENSION(:,:) :: esrft , smrft ! snow energy & salinity of rafting ice847 REAL(wp), POINTER, DIMENSION(:,:) :: oirft1, oirft2 ! ice age of ice rafted848 849 REAL(wp), POINTER, DIMENSION(:,:,:) :: eirft ! ice energy of rafting ice850 REAL(wp), POINTER, DIMENSION(:,:,:) :: erdg1 ! enth*volume of ice ridged851 REAL(wp), POINTER, DIMENSION(:,:,:) :: erdg2 ! enth*volume of new ridges852 REAL(wp), POINTER, DIMENSION(:,:,:) :: ersw ! enth of water trapped into ridges853 !!----------------------------------------------------------------------854 855 CALL wrk_alloc( (jpi+1)*(jpj+1), indxi, indxj )856 CALL wrk_alloc( jpi, jpj, vice_init, vice_final, eice_init, eice_final )857 CALL wrk_alloc( jpi, jpj, afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 )858 CALL wrk_alloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 )859 CALL wrk_alloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 )860 CALL wrk_alloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init )861 CALL wrk_alloc( jpi, jpj, nlay_i, eirft, erdg1, erdg2, ersw )862 CALL wrk_alloc( jpi, jpj, nlay_i, jpl, eicen_init )863 864 ! Conservation check865 eice_init(:,:) = 0._wp866 867 IF( con_i ) THEN868 CALL lim_column_sum (jpl, v_i, vice_init )869 CALL lim_column_sum_energy (jpl, nlay_i, e_i, eice_init )870 DO ji = mi0(iiceprt), mi1(iiceprt)871 DO jj = mj0(jiceprt), mj1(jiceprt)872 WRITE(numout,*) ' vice_init : ', vice_init(ji,jj)873 WRITE(numout,*) ' eice_init : ', eice_init(ji,jj)874 END DO875 END DO876 ENDIF877 878 !-------------------------------------------------------------------------------879 ! 1) Compute change in open water area due to closing and opening.880 !-------------------------------------------------------------------------------881 DO jj = 1, jpj882 DO ji = 1, jpi883 ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice &884 & + opning(ji,jj) * rdt_ice885 IF ( ato_i(ji,jj) < -epsi10 ) THEN ! there is a bug886 IF(lwp) WRITE(numout,*) 'Ridging error: ato_i < 0 -- ato_i : ',ato_i(ji,jj)887 ELSEIF( ato_i(ji,jj) < 0._wp ) THEN ! roundoff error888 ato_i(ji,jj) = 0._wp889 ENDIF890 END DO891 END DO892 893 !-----------------------------------------------------------------894 ! 2) Save initial state variables895 !-----------------------------------------------------------------896 aicen_init(:,:,:) = a_i (:,:,:)897 vicen_init(:,:,:) = v_i (:,:,:)898 vsnwn_init(:,:,:) = v_s (:,:,:)899 smv_i_init(:,:,:) = smv_i(:,:,:)900 esnwn_init(:,:,:) = e_s (:,:,1,:)901 eicen_init(:,:,:,:) = e_i (:,:,:,:)902 oa_i_init (:,:,:) = oa_i (:,:,:)903 904 !905 !-----------------------------------------------------------------906 ! 3) Pump everything from ice which is being ridged / rafted907 !-----------------------------------------------------------------908 ! Compute the area, volume, and energy of ice ridging in each909 ! category, along with the area of the resulting ridge.910 911 DO jl1 = 1, jpl !jl1 describes the ridging category912 913 !------------------------------------------------914 ! 3.1) Identify grid cells with nonzero ridging915 !------------------------------------------------916 917 icells = 0918 DO jj = 1, jpj919 DO ji = 1, jpi920 IF( aicen_init(ji,jj,jl1) > epsi10 .AND. athorn(ji,jj,jl1) > 0._wp &921 & .AND. closing_gross(ji,jj) > 0._wp ) THEN922 icells = icells + 1923 indxi(icells) = ji924 indxj(icells) = jj925 ENDIF926 END DO927 END DO928 929 DO ij = 1, icells930 ji = indxi(ij)931 jj = indxj(ij)932 933 !--------------------------------------------------------------------934 ! 3.2) Compute area of ridging ice (ardg1) and of new ridge (ardg2)935 !--------------------------------------------------------------------936 937 ardg1(ji,jj) = aridge(ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice938 arft1(ji,jj) = araft (ji,jj,jl1)*closing_gross(ji,jj)*rdt_ice939 ardg2(ji,jj) = ardg1(ji,jj) / krdg(ji,jj,jl1)940 arft2(ji,jj) = arft1(ji,jj) / kraft941 942 !---------------------------------------------------------------943 ! 3.3) Compute ridging /rafting fractions, make sure afrac <=1944 !---------------------------------------------------------------945 946 afrac(ji,jj) = ardg1(ji,jj) / aicen_init(ji,jj,jl1) !ridging947 afrft(ji,jj) = arft1(ji,jj) / aicen_init(ji,jj,jl1) !rafting948 949 IF( afrac(ji,jj) > kamax + epsi10 ) THEN ! there is a bug950 IF(lwp) WRITE(numout,*) ' ardg > a_i -- ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1)951 ELSEIF( afrac(ji,jj) > kamax ) THEN ! roundoff error952 afrac(ji,jj) = kamax953 ENDIF954 955 IF( afrft(ji,jj) > kamax + epsi10 ) THEN ! there is a bug956 IF(lwp) WRITE(numout,*) ' arft > a_i -- arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1)957 ELSEIF( afrft(ji,jj) > kamax) THEN ! roundoff error958 afrft(ji,jj) = kamax959 ENDIF960 961 !--------------------------------------------------------------------------962 ! 3.4) Subtract area, volume, and energy from ridging963 ! / rafting category n1.964 !--------------------------------------------------------------------------965 vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj)966 vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + rn_por_rdg )967 vsw (ji,jj) = vrdg1(ji,jj) * rn_por_rdg968 969 vsrdg (ji,jj) = vsnwn_init(ji,jj,jl1) * afrac(ji,jj)970 esrdg (ji,jj) = esnwn_init(ji,jj,jl1) * afrac(ji,jj)971 srdg1 (ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj)972 oirdg1(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj)973 oirdg2(ji,jj) = oa_i_init (ji,jj,jl1) * afrac(ji,jj) / krdg(ji,jj,jl1)974 975 ! rafting volumes, heat contents ...976 virft (ji,jj) = vicen_init(ji,jj,jl1) * afrft(ji,jj)977 vsrft (ji,jj) = vsnwn_init(ji,jj,jl1) * afrft(ji,jj)978 esrft (ji,jj) = esnwn_init(ji,jj,jl1) * afrft(ji,jj)979 smrft (ji,jj) = smv_i_init(ji,jj,jl1) * afrft(ji,jj)980 oirft1(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj)981 oirft2(ji,jj) = oa_i_init (ji,jj,jl1) * afrft(ji,jj) / kraft982 983 ! substract everything984 a_i(ji,jj,jl1) = a_i(ji,jj,jl1) - ardg1 (ji,jj) - arft1 (ji,jj)985 v_i(ji,jj,jl1) = v_i(ji,jj,jl1) - vrdg1 (ji,jj) - virft (ji,jj)986 v_s(ji,jj,jl1) = v_s(ji,jj,jl1) - vsrdg (ji,jj) - vsrft (ji,jj)987 e_s(ji,jj,1,jl1) = e_s(ji,jj,1,jl1) - esrdg (ji,jj) - esrft (ji,jj)988 smv_i(ji,jj,jl1) = smv_i(ji,jj,jl1) - srdg1 (ji,jj) - smrft (ji,jj)989 oa_i(ji,jj,jl1) = oa_i(ji,jj,jl1) - oirdg1(ji,jj) - oirft1(ji,jj)990 991 !-----------------------------------------------------------------992 ! 3.5) Compute properties of new ridges993 !-----------------------------------------------------------------994 !---------995 ! Salinity996 !---------997 smsw(ji,jj) = vsw(ji,jj) * sss_m(ji,jj) ! salt content of seawater frozen in voids !! MV HC2014998 srdg2(ji,jj) = srdg1(ji,jj) + smsw(ji,jj) ! salt content of new ridge999 1000 !srdg2(ji,jj) = MIN( rn_simax * vrdg2(ji,jj) , zsrdg2 ) ! impose a maximum salinity1001 1002 sfx_dyn(ji,jj) = sfx_dyn(ji,jj) - smsw(ji,jj) * rhoic * r1_rdtice1003 wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ji,jj) * rhoic * r1_rdtice ! increase in ice volume du to seawater frozen in voids1004 1005 !------------------------------------1006 ! 3.6 Increment ridging diagnostics1007 !------------------------------------1008 1009 ! jl1 looping 1-jpl1010 ! ij looping 1-icells1011 1012 dardg1dt (ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj)1013 dardg2dt (ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj)1014 opening (ji,jj) = opening (ji,jj) + opning(ji,jj) * rdt_ice1015 1016 IF( con_i ) vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj)1017 1018 !------------------------------------------1019 ! 3.7 Put the snow somewhere in the ocean1020 !------------------------------------------1021 ! Place part of the snow lost by ridging into the ocean.1022 ! Note that esnow_mlt < 0; the ocean must cool to melt snow.1023 ! If the ocean temp = Tf already, new ice must grow.1024 ! During the next time step, thermo_rates will determine whether1025 ! the ocean cools or new ice grows.1026 ! jl1 looping 1-jpl1027 ! ij looping 1-icells1028 1029 msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-rn_fsnowrdg) & ! rafting included1030 & + rhosn*vsrft(ji,jj)*(1.0-rn_fsnowrft)1031 1032 ! in J/m2 (same as e_s)1033 esnow_mlt(ji,jj) = esnow_mlt(ji,jj) - esrdg(ji,jj)*(1.0-rn_fsnowrdg) & !rafting included1034 & - esrft(ji,jj)*(1.0-rn_fsnowrft)1035 1036 !-----------------------------------------------------------------1037 ! 3.8 Compute quantities used to apportion ice among categories1038 ! in the n2 loop below1039 !-----------------------------------------------------------------1040 1041 ! jl1 looping 1-jpl1042 ! ij looping 1-icells1043 1044 dhr (ji,jj) = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1)1045 dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1)1046 1047 END DO1048 1049 !--------------------------------------------------------------------1050 ! 3.9 Compute ridging ice enthalpy, remove it from ridging ice and1051 ! compute ridged ice enthalpy1052 !--------------------------------------------------------------------1053 DO jk = 1, nlay_i1054 DO ij = 1, icells1055 ji = indxi(ij)1056 jj = indxj(ij)1057 ! heat content of ridged ice1058 erdg1(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj)1059 eirft(ji,jj,jk) = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj)1060 e_i (ji,jj,jk,jl1) = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk)1061 1062 1063 ! enthalpy of the trapped seawater (J/m2, >0)1064 ! clem: if sst>0, then ersw <0 (is that possible?)1065 ersw(ji,jj,jk) = - rhoic * vsw(ji,jj) * rcp * sst_m(ji,jj) * r1_nlay_i1066 1067 ! heat flux to the ocean1068 hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ersw(ji,jj,jk) * r1_rdtice ! > 0 [W.m-2] ocean->ice flux1069 1070 ! it is added to sea ice because the sign convention is the opposite of the sign convention for the ocean1071 erdg2(ji,jj,jk) = erdg1(ji,jj,jk) + ersw(ji,jj,jk)1072 1073 END DO1074 END DO1075 1076 1077 IF( con_i ) THEN1078 DO jk = 1, nlay_i1079 DO ij = 1, icells1080 ji = indxi(ij)1081 jj = indxj(ij)1082 eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk)1083 END DO1084 END DO1085 ENDIF1086 1087 !-------------------------------------------------------------------------------1088 ! 4) Add area, volume, and energy of new ridge to each category jl21089 !-------------------------------------------------------------------------------1090 ! jl1 looping 1-jpl1091 DO jl2 = 1, jpl1092 ! over categories to which ridged ice is transferred1093 DO ij = 1, icells1094 ji = indxi(ij)1095 jj = indxj(ij)1096 1097 ! Compute the fraction of ridged ice area and volume going to1098 ! thickness category jl2.1099 ! Transfer area, volume, and energy accordingly.1100 1101 IF( hrmin(ji,jj,jl1) >= hi_max(jl2) .OR. hrmax(ji,jj,jl1) <= hi_max(jl2-1) ) THEN1102 hL = 0._wp1103 hR = 0._wp1104 ELSE1105 hL = MAX( hrmin(ji,jj,jl1), hi_max(jl2-1) )1106 hR = MIN( hrmax(ji,jj,jl1), hi_max(jl2) )1107 ENDIF1108 1109 ! fraction of ridged ice area and volume going to n21110 farea = ( hR - hL ) / dhr(ji,jj)1111 fvol(ji,jj) = ( hR*hR - hL*hL ) / dhr2(ji,jj)1112 1113 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + ardg2 (ji,jj) * farea1114 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + vrdg2 (ji,jj) * fvol(ji,jj)1115 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + vsrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg1116 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * rn_fsnowrdg1117 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + srdg2 (ji,jj) * fvol(ji,jj)1118 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + oirdg2(ji,jj) * farea1119 1120 END DO1121 1122 ! Transfer ice energy to category jl2 by ridging1123 DO jk = 1, nlay_i1124 DO ij = 1, icells1125 ji = indxi(ij)1126 jj = indxj(ij)1127 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj) * erdg2(ji,jj,jk)1128 END DO1129 END DO1130 !1131 END DO ! jl2 (new ridges)1132 1133 DO jl2 = 1, jpl1134 1135 DO ij = 1, icells1136 ji = indxi(ij)1137 jj = indxj(ij)1138 ! Compute the fraction of rafted ice area and volume going to1139 ! thickness category jl2, transfer area, volume, and energy accordingly.1140 !1141 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN1142 a_i (ji,jj ,jl2) = a_i (ji,jj ,jl2) + arft2 (ji,jj)1143 v_i (ji,jj ,jl2) = v_i (ji,jj ,jl2) + virft (ji,jj)1144 v_s (ji,jj ,jl2) = v_s (ji,jj ,jl2) + vsrft (ji,jj) * rn_fsnowrft1145 e_s (ji,jj,1,jl2) = e_s (ji,jj,1,jl2) + esrft (ji,jj) * rn_fsnowrft1146 smv_i(ji,jj ,jl2) = smv_i(ji,jj ,jl2) + smrft (ji,jj)1147 oa_i (ji,jj ,jl2) = oa_i (ji,jj ,jl2) + oirft2(ji,jj)1148 ENDIF1149 !1150 END DO1151 1152 ! Transfer rafted ice energy to category jl21153 DO jk = 1, nlay_i1154 DO ij = 1, icells1155 ji = indxi(ij)1156 jj = indxj(ij)1157 IF( hraft(ji,jj,jl1) <= hi_max(jl2) .AND. hraft(ji,jj,jl1) > hi_max(jl2-1) ) THEN1158 e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk)1159 ENDIF1160 END DO1161 END DO1162 1163 END DO1164 1165 END DO ! jl1 (deforming categories)1166 1167 ! Conservation check1168 IF ( con_i ) THEN1169 CALL lim_column_sum (jpl, v_i, vice_final)1170 fieldid = ' v_i : limitd_me '1171 CALL lim_cons_check (vice_init, vice_final, 1.0e-6, fieldid)1172 1173 CALL lim_column_sum_energy (jpl, nlay_i, e_i, eice_final )1174 fieldid = ' e_i : limitd_me '1175 CALL lim_cons_check (eice_init, eice_final, 1.0e-2, fieldid)1176 1177 DO ji = mi0(iiceprt), mi1(iiceprt)1178 DO jj = mj0(jiceprt), mj1(jiceprt)1179 WRITE(numout,*) ' vice_init : ', vice_init (ji,jj)1180 WRITE(numout,*) ' vice_final : ', vice_final(ji,jj)1181 WRITE(numout,*) ' eice_init : ', eice_init (ji,jj)1182 WRITE(numout,*) ' eice_final : ', eice_final(ji,jj)1183 END DO1184 END DO1185 ENDIF1186 !1187 CALL wrk_dealloc( (jpi+1)*(jpj+1), indxi, indxj )1188 CALL wrk_dealloc( jpi, jpj, vice_init, vice_final, eice_init, eice_final )1189 CALL wrk_dealloc( jpi, jpj, afrac, fvol , ardg1, ardg2, vsrdg, esrdg, dhr, dhr2 )1190 CALL wrk_dealloc( jpi, jpj, vrdg1, vrdg2, vsw , srdg1, srdg2, smsw, oirdg1, oirdg2 )1191 CALL wrk_dealloc( jpi, jpj, afrft, arft1, arft2, virft, vsrft, esrft, smrft, oirft1, oirft2 )1192 CALL wrk_dealloc( jpi, jpj, jpl, aicen_init, vicen_init, vsnwn_init, esnwn_init, smv_i_init, oa_i_init )1193 CALL wrk_dealloc( jpi, jpj, nlay_i, eirft, erdg1, erdg2, ersw )1194 CALL wrk_dealloc( jpi, jpj, nlay_i, jpl, eicen_init )1195 !1196 END SUBROUTINE lim_itd_me_ridgeshift1197 933 1198 934 SUBROUTINE lim_itd_me_init -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90
r5407 r6455 94 94 !! - fr_i : ice fraction 95 95 !! - tn_ice : sea-ice surface temperature 96 !! - alb_ice : sea-ice albedo ( only useful incoupled mode)96 !! - alb_ice : sea-ice albedo (recomputed only for coupled mode) 97 97 !! 98 98 !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. … … 106 106 REAL(wp) :: zqsr ! New solar flux received by the ocean 107 107 ! 108 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_cs, zalb_os ! 2D/3D workspace 108 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_cs, zalb_os ! 3D workspace 109 REAL(wp), POINTER, DIMENSION(:,:) :: zalb ! 2D workspace 109 110 !!--------------------------------------------------------------------- 110 111 111 112 ! make calls for heat fluxes before it is modified 113 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 112 114 IF( iom_use('qsr_oce') ) CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) ) ! solar flux at ocean surface 113 115 IF( iom_use('qns_oce') ) CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) ) ! non-solar flux at ocean surface … … 118 120 IF( iom_use('qt_ice' ) ) CALL iom_put( "qt_ice" , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) ) & 119 121 & * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 120 IF( iom_use('qemp_oce' ) ) CALL iom_put( "qemp_oce" , qemp_oce(:,:) ) 121 IF( iom_use('qemp_ice' ) ) CALL iom_put( "qemp_ice" , qemp_ice(:,:) ) 122 123 ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 122 IF( iom_use('qemp_oce') ) CALL iom_put( "qemp_oce" , qemp_oce(:,:) ) 123 IF( iom_use('qemp_ice') ) CALL iom_put( "qemp_ice" , qemp_ice(:,:) ) 124 IF( iom_use('emp_oce' ) ) CALL iom_put( "emp_oce" , emp_oce(:,:) ) ! emp over ocean (taking into account the snow blown away from the ice) 125 IF( iom_use('emp_ice' ) ) CALL iom_put( "emp_ice" , emp_ice(:,:) ) ! emp over ice (taking into account the snow blown away from the ice) 126 127 ! albedo output 128 CALL wrk_alloc( jpi,jpj, zalb ) 129 130 zalb(:,:) = 0._wp 131 WHERE ( SUM( a_i_b, dim=3 ) <= epsi06 ) ; zalb(:,:) = 0.066_wp 132 ELSEWHERE ; zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 133 END WHERE 134 IF( iom_use('alb_ice' ) ) CALL iom_put( "alb_ice" , zalb(:,:) ) ! ice albedo output 135 136 zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) ) 137 IF( iom_use('albedo' ) ) CALL iom_put( "albedo" , zalb(:,:) ) ! ice albedo output 138 139 CALL wrk_dealloc( jpi,jpj, zalb ) 140 ! 141 124 142 DO jj = 1, jpj 125 143 DO ji = 1, jpi … … 140 158 hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 141 159 142 ! Add the residual from heat diffusion equation (W.m-2) 143 !------------------------------------------------------- 144 hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 160 ! Add the residual from heat diffusion equation and sublimation (W.m-2) 161 !---------------------------------------------------------------------- 162 hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) + & 163 & ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 145 164 146 165 ! New qsr and qns used to compute the oceanic heat flux at the next time step 147 !--------------------------------------------------- 166 !---------------------------------------------------------------------------- 148 167 qsr(ji,jj) = zqsr 149 168 qns(ji,jj) = hfx_out(ji,jj) - zqsr … … 165 184 166 185 ! mass flux at the ocean/ice interface 167 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice ! F/M mass flux save at least for biogeochemical model 168 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 169 186 fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) ) ! F/M mass flux save at least for biogeochemical model 187 emp(ji,jj) = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj) ! mass flux + F/M mass flux (always ice/ocean mass exchange) 170 188 END DO 171 189 END DO … … 175 193 !------------------------------------------! 176 194 sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:) & 177 & + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 195 & + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 178 196 179 197 !-------------------------------------------------------------! -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90
r5407 r6455 461 461 462 462 DO ji = kideb, kiut 463 zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) )463 zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 464 464 IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp ) THEN 465 465 zvi = a_i_1d(ji) * ht_i_1d(ji) … … 470 470 zda_mel = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) 471 471 a_i_1d(ji) = MAX( epsi20, a_i_1d(ji) + zda_mel ) 472 472 ! adjust thickness 473 473 ht_i_1d(ji) = zvi / a_i_1d(ji) 474 474 ht_s_1d(ji) = zvs / a_i_1d(ji) … … 514 514 515 515 CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 516 CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 516 517 CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 517 518 CALL tab_2d_1d( nbpb, fr1_i0_1d (1:nbpb), fr1_i0 , jpi, jpj, npb(1:nbpb) ) … … 543 544 CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri , jpi, jpj, npb(1:nbpb) ) 544 545 CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res , jpi, jpj, npb(1:nbpb) ) 545 546 CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub , jpi, jpj,npb(1:nbpb) ) 547 546 548 CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd , jpi, jpj, npb(1:nbpb) ) 547 549 CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr , jpi, jpj, npb(1:nbpb) ) … … 593 595 CALL tab_1d_2d( nbpb, sfx_res , npb, sfx_res_1d(1:nbpb) , jpi, jpj ) 594 596 CALL tab_1d_2d( nbpb, sfx_bri , npb, sfx_bri_1d(1:nbpb) , jpi, jpj ) 595 597 CALL tab_1d_2d( nbpb, sfx_sub , npb, sfx_sub_1d(1:nbpb) , jpi, jpj ) 598 596 599 CALL tab_1d_2d( nbpb, hfx_thd , npb, hfx_thd_1d(1:nbpb) , jpi, jpj ) 597 600 CALL tab_1d_2d( nbpb, hfx_spr , npb, hfx_spr_1d(1:nbpb) , jpi, jpj ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90
r5487 r6455 74 74 75 75 REAL(wp) :: ztmelts ! local scalar 76 REAL(wp) :: z fdum76 REAL(wp) :: zdum 77 77 REAL(wp) :: zfracs ! fractionation coefficient for bottom salt entrapment 78 78 REAL(wp) :: zs_snic ! snow-ice salinity … … 95 95 REAL(wp), POINTER, DIMENSION(:) :: zq_rema ! remaining heat at the end of the routine (J.m-2) 96 96 REAL(wp), POINTER, DIMENSION(:) :: zf_tt ! Heat budget to determine melting or freezing(W.m-2) 97 REAL(wp), POINTER, DIMENSION(:) :: zevap_rema ! remaining mass flux from sublimation (kg.m-2) 97 98 98 99 REAL(wp), POINTER, DIMENSION(:) :: zdh_s_mel ! snow melt … … 105 106 106 107 REAL(wp), POINTER, DIMENSION(:) :: zqh_i ! total ice heat content (J.m-2) 107 REAL(wp), POINTER, DIMENSION(:) :: zqh_s ! total snow heat content (J.m-2)108 REAL(wp), POINTER, DIMENSION(:) :: zq_s ! total snow enthalpy (J.m-3)109 108 REAL(wp), POINTER, DIMENSION(:) :: zsnw ! distribution of snow after wind blowing 110 109 … … 122 121 END SELECT 123 122 124 CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw )125 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i , zqh_s, zq_s)123 CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 124 CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 126 125 CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 127 126 CALL wrk_alloc( jpij, nlay_i, icount ) 128 127 129 dh_i_surf (:) = 0._wp ; dh_i_bott (:) = 0._wp ; dh_snowice(:) = 0._wp 128 dh_i_surf (:) = 0._wp ; dh_i_bott (:) = 0._wp ; dh_snowice(:) = 0._wp ; dh_i_sub(:) = 0._wp 130 129 dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp 131 130 132 131 zqprec (:) = 0._wp ; zq_su (:) = 0._wp ; zq_bo (:) = 0._wp ; zf_tt(:) = 0._wp 133 zq_rema (:) = 0._wp ; zsnw (:) = 0._wp 132 zq_rema (:) = 0._wp ; zsnw (:) = 0._wp ; zevap_rema(:) = 0._wp ; 134 133 zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 135 zqh_s (:) = 0._wp ; zq_s (:) = 0._wp136 134 137 135 zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp … … 159 157 ! 160 158 DO ji = kideb, kiut 161 z fdum= qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)159 zdum = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji) 162 160 zf_tt(ji) = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji) 163 161 164 zq_su (ji) = MAX( 0._wp, z fdum* rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) )162 zq_su (ji) = MAX( 0._wp, zdum * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 165 163 zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 166 164 END DO … … 187 185 ! 2) Computing layer thicknesses and enthalpies. ! 188 186 !------------------------------------------------------------! 189 !190 DO jk = 1, nlay_s191 DO ji = kideb, kiut192 zqh_s(ji) = zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s193 END DO194 END DO195 187 ! 196 188 DO jk = 1, nlay_i … … 275 267 END DO 276 268 277 !---------------------- 278 ! 3.2 S now sublimation279 !---------------------- 269 !------------------------------ 270 ! 3.2 Sublimation (part1: snow) 271 !------------------------------ 280 272 ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 281 273 ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 282 ! clem comment: ice should also sublimate283 274 zdeltah(:,:) = 0._wp 284 ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 285 ! forced mode: snow thickness change due to sublimation 286 DO ji = kideb, kiut 287 zdh_s_sub(ji) = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 288 ! Heat flux by sublimation [W.m-2], < 0 289 ! sublimate first snow that had fallen, then pre-existing snow 275 DO ji = kideb, kiut 276 zdh_s_sub(ji) = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 277 ! remaining evap in kg.m-2 (used for ice melting later on) 278 zevap_rema(ji) = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn 279 ! Heat flux by sublimation [W.m-2], < 0 (sublimate first snow that had fallen, then pre-existing snow) 290 280 zdeltah(ji,1) = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 291 281 hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1) & … … 309 299 !------------------------------------------- 310 300 ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 311 zq_s(:) = 0._wp312 301 DO jk = 1, nlay_s 313 302 DO ji = kideb,kiut 314 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 315 q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) * & 316 & ( ( zdh_s_pre(ji) ) * zqprec(ji) + & 317 & ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 318 zq_s(ji) = zq_s(ji) + q_s_1d(ji,jk) 303 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 304 q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) * & 305 & ( ( zdh_s_pre(ji) ) * zqprec(ji) + & 306 & ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 319 307 END DO 320 308 END DO … … 370 358 zQm = zfmdt * zEw ! Energy of the melt water sent to the ocean [J/m2, <0] 371 359 372 ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok)360 ! Contribution to salt flux >0 (clem: using sm_i_1d and not s_i_1d(jk) is ok) 373 361 sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 374 362 … … 383 371 384 372 END IF 373 ! ---------------------- 374 ! Sublimation part2: ice 375 ! ---------------------- 376 zdum = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic ) 377 zdeltah(ji,jk) = zdeltah(ji,jk) + zdum 378 dh_i_sub(ji) = dh_i_sub(ji) + zdum 379 ! Salt flux > 0 (clem2016: flux is sent to the ocean for simplicity but salt should remain in the ice except if all ice is melted. 380 ! It must be corrected at some point) 381 sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * sm_i_1d(ji) * r1_rdtice 382 ! Heat flux [W.m-2], < 0 383 hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * q_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice 384 ! Mass flux > 0 385 wfx_sub_1d(ji) = wfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice 386 ! update remaining mass flux 387 zevap_rema(ji) = zevap_rema(ji) + zdum * rhoic 388 385 389 ! record which layers have disappeared (for bottom melting) 386 390 ! => icount=0 : no layer has vanished … … 389 393 icount(ji,jk) = NINT( rswitch ) 390 394 zh_i(ji,jk) = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 391 395 392 396 ! update heat content (J.m-2) and layer thickness 393 397 qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) … … 397 401 ! update ice thickness 398 402 DO ji = kideb, kiut 399 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 403 ht_i_1d(ji) = MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) ) 404 END DO 405 406 ! remaining "potential" evap is sent to ocean 407 DO ji = kideb, kiut 408 ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 409 wfx_err_sub(ii,ij) = wfx_err_sub(ii,ij) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice ! <=0 (net evap for the ocean in kg.m-2.s-1) 400 410 END DO 401 411 … … 686 696 WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 687 697 688 CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw )689 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i , zqh_s, zq_s)698 CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 699 CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 690 700 CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 691 701 CALL wrk_dealloc( jpij, nlay_i, icount ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90
r5202 r6455 75 75 INTEGER :: ii, ij, iter ! - - 76 76 REAL(wp) :: ztmelts, zdv, zfrazb, zweight, zde ! local scalars 77 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new! - -77 REAL(wp) :: zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf ! - - 78 78 REAL(wp) :: ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit ! - - 79 LOGICAL :: iterate_frazil ! iterate frazil ice collection thickness80 79 CHARACTER (len = 15) :: fieldid 81 80 … … 108 107 REAL(wp), POINTER, DIMENSION(:,:) :: zsmv_i_1d ! 1-D version of smv_i 109 108 110 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d 111 112 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel 113 114 REAL(wp) :: zcai = 1.4e-3_wp 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze_i_1d !: 1-D version of e_i 110 111 REAL(wp), POINTER, DIMENSION(:,:) :: zvrel ! relative ice / frazil velocity 112 113 REAL(wp) :: zcai = 1.4e-3_wp ! ice-air drag (clem: should be dependent on coupling/forcing used) 115 114 !!-----------------------------------------------------------------------! 116 115 … … 143 142 !------------------------------------------------------------------------------! 144 143 ! hicol is the thickness of new ice formed in open water 145 ! hicol can be either prescribed (frazswi = 0) 146 ! or computed (frazswi = 1) 144 ! hicol can be either prescribed (frazswi = 0) or computed (frazswi = 1) 147 145 ! Frazil ice forms in open water, is transported by wind 148 146 ! accumulates at the edge of the consolidated ice edge … … 155 153 zvrel(:,:) = 0._wp 156 154 157 ! Default new ice thickness 158 hicol(:,:) = rn_hnewice 155 ! Default new ice thickness 156 WHERE( qlead(:,:) < 0._wp ) ; hicol = rn_hnewice 157 ELSEWHERE ; hicol = 0._wp 158 END WHERE 159 159 160 160 IF( ln_frazil ) THEN … … 182 182 & + vtau_ice(ji ,jj ) * vmask(ji ,jj ,1) ) * 0.5_wp 183 183 ! Square root of wind stress 184 ztenagm = SQRT( SQRT( ztaux **2 + ztauy**2) )184 ztenagm = SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 185 185 186 186 !--------------------- … … 205 205 zvrel2 = MAX( ( zvfrx - zvgx ) * ( zvfrx - zvgx ) & 206 206 & + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) 207 zvrel(ji,jj) 207 zvrel(ji,jj) = SQRT( zvrel2 ) 208 208 209 209 !--------------------- 210 210 ! Iterative procedure 211 211 !--------------------- 212 hicol(ji,jj) = zhicrit + 0.1 213 hicol(ji,jj) = zhicrit + hicol(ji,jj) & 214 & / ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) * ztwogp * zvrel2 215 216 !!gm better coding: above: hicol(ji,jj) * hicol(ji,jj) = (zhicrit + 0.1)*(zhicrit + 0.1) 217 !!gm = zhicrit**2 + 0.2*zhicrit +0.01 218 !!gm therefore the 2 lines with hicol can be replaced by 1 line: 219 !!gm hicol(ji,jj) = zhicrit + (zhicrit + 0.1) / ( 0.2 * zhicrit + 0.01 ) * ztwogp * zvrel2 220 !!gm further more (zhicrit + 0.1)/(0.2 * zhicrit + 0.01 )*ztwogp can be computed one for all outside the DO loop 212 hicol(ji,jj) = zhicrit + ( zhicrit + 0.1 ) & 213 & / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) - zhicrit * zhicrit ) * ztwogp * zvrel2 221 214 222 215 iter = 1 223 iterate_frazil = .true. 224 225 DO WHILE ( iter < 100 .AND. iterate_frazil ) 226 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 227 - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 228 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 229 - zhicrit * ztwogp * zvrel2 230 zhicol_new = hicol(ji,jj) - zf/zfp 231 hicol(ji,jj) = zhicol_new 232 216 DO WHILE ( iter < 20 ) 217 zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) - & 218 & hicol(ji,jj) * zhicrit * ztwogp * zvrel2 219 zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0 * hicol(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 220 221 hicol(ji,jj) = hicol(ji,jj) - zf/zfp 233 222 iter = iter + 1 234 235 END DO ! do while 223 END DO 236 224 237 225 ENDIF ! end of selection of pixels where ice forms 238 226 239 END DO ! loop on ji ends240 END DO ! loop on jj ends241 !242 CALL lbc_lnk( zvrel(:,:), 'T', 1. )243 CALL lbc_lnk( hicol(:,:), 'T', 1. )227 END DO 228 END DO 229 ! 230 CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 231 CALL lbc_lnk( hicol(:,:), 'T', 1. ) 244 232 245 233 ENDIF ! End of computation of frazil ice collection thickness … … 282 270 ! Move from 2-D to 1-D vectors 283 271 !------------------------------ 284 ! If ocean gains heat do nothing 285 ! 0therwise compute new ice formation 272 ! If ocean gains heat do nothing. Otherwise compute new ice formation 286 273 287 274 IF ( nbpac > 0 ) THEN … … 297 284 END DO 298 285 299 CALL tab_2d_1d( nbpac, qlead_1d (1:nbpac) , qlead , jpi, jpj, npac(1:nbpac) ) 300 CALL tab_2d_1d( nbpac, t_bo_1d (1:nbpac) , t_bo , jpi, jpj, npac(1:nbpac) ) 301 CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac) , sfx_opw, jpi, jpj, npac(1:nbpac) ) 302 CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac) , wfx_opw, jpi, jpj, npac(1:nbpac) ) 303 CALL tab_2d_1d( nbpac, hicol_1d (1:nbpac) , hicol , jpi, jpj, npac(1:nbpac) ) 304 CALL tab_2d_1d( nbpac, zvrel_1d (1:nbpac) , zvrel , jpi, jpj, npac(1:nbpac) ) 305 306 CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac) , hfx_thd, jpi, jpj, npac(1:nbpac) ) 307 CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac) , hfx_opw, jpi, jpj, npac(1:nbpac) ) 286 CALL tab_2d_1d( nbpac, qlead_1d (1:nbpac) , qlead , jpi, jpj, npac(1:nbpac) ) 287 CALL tab_2d_1d( nbpac, t_bo_1d (1:nbpac) , t_bo , jpi, jpj, npac(1:nbpac) ) 288 CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac) , sfx_opw , jpi, jpj, npac(1:nbpac) ) 289 CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac) , wfx_opw , jpi, jpj, npac(1:nbpac) ) 290 CALL tab_2d_1d( nbpac, hicol_1d (1:nbpac) , hicol , jpi, jpj, npac(1:nbpac) ) 291 CALL tab_2d_1d( nbpac, zvrel_1d (1:nbpac) , zvrel , jpi, jpj, npac(1:nbpac) ) 292 293 CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac) , hfx_thd , jpi, jpj, npac(1:nbpac) ) 294 CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac) , hfx_opw , jpi, jpj, npac(1:nbpac) ) 295 CALL tab_2d_1d( nbpac, rn_amax_1d(1:nbpac) , rn_amax_2d, jpi, jpj, npac(1:nbpac) ) 308 296 309 297 !------------------------------------------------------------------------------! … … 316 304 zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:) 317 305 za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 306 318 307 !---------------------- 319 308 ! Thickness of new ice 320 309 !---------------------- 321 DO ji = 1, nbpac 322 zh_newice(ji) = rn_hnewice 323 END DO 324 IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 310 zh_newice(1:nbpac) = hicol_1d(1:nbpac) 325 311 326 312 !---------------------- … … 384 370 ! salt flux 385 371 sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 386 372 END DO 373 374 zv_frazb(:) = 0._wp 375 IF( ln_frazil ) THEN 387 376 ! A fraction zfrazb of frazil ice is accreted at the ice bottom 388 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 389 zfrazb = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 390 zv_frazb(ji) = zfrazb * zv_newice(ji) 391 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 392 END DO 393 377 DO ji = 1, nbpac 378 rswitch = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 379 zfrazb = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 380 zv_frazb(ji) = zfrazb * zv_newice(ji) 381 zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 382 END DO 383 END IF 384 394 385 !----------------- 395 386 ! Area of new ice … … 409 400 ! we keep the excessive volume in memory and attribute it later to bottom accretion 410 401 DO ji = 1, nbpac 411 IF ( za_newice(ji) > ( rn_amax - zat_i_1d(ji) ) ) THEN412 zda_res(ji) = za_newice(ji) - ( rn_amax - zat_i_1d(ji) )402 IF ( za_newice(ji) > ( rn_amax_1d(ji) - zat_i_1d(ji) ) ) THEN 403 zda_res(ji) = za_newice(ji) - ( rn_amax_1d(ji) - zat_i_1d(ji) ) 413 404 zdv_res(ji) = zda_res (ji) * zh_newice(ji) 414 405 za_newice(ji) = za_newice(ji) - zda_res (ji) … … 443 434 jl = jcat(ji) 444 435 rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 445 ze_i_1d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + 436 ze_i_1d(ji,jk,jl) = zswinew(ji) * ze_newice(ji) + & 446 437 & ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) ) & 447 438 & * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90
r5202 r6455 422 422 DO jj = 1, jpj 423 423 DO ji = 1, jpi 424 a_i(ji,jj,1) = MIN( a_i(ji,jj,1), rn_amax )424 a_i(ji,jj,1) = MIN( a_i(ji,jj,1), rn_amax_2d(ji,jj) ) 425 425 END DO 426 426 END DO -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90
r5215 r6455 80 80 DO jj = 1, jpj 81 81 DO ji = 1, jpi 82 IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN83 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )84 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )82 IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 83 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 84 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 85 85 ENDIF 86 86 END DO -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90
r5410 r6455 94 94 DO jj = 1, jpj 95 95 DO ji = 1, jpi 96 IF( at_i(ji,jj) > rn_amax .AND. a_i(ji,jj,jl) > 0._wp ) THEN97 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )98 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax / at_i(ji,jj) ) )96 IF( at_i(ji,jj) > rn_amax_2d(ji,jj) .AND. a_i(ji,jj,jl) > 0._wp ) THEN 97 a_i (ji,jj,jl) = a_i (ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 98 oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1._wp - ( 1._wp - rn_amax_2d(ji,jj) / at_i(ji,jj) ) ) 99 99 ENDIF 100 100 END DO -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90
r5202 r6455 163 163 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) !0 if no ice and 1 if yes 164 164 ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 165 END DO 166 END DO 167 END DO 168 ! Force the upper limit of ht_i to always be < hi_max (99 m). 169 DO jj = 1, jpj 170 DO ji = 1, jpi 171 rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 172 ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 173 a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 174 END DO 175 END DO 176 177 DO jl = 1, jpl 178 DO jj = 1, jpj 179 DO ji = 1, jpi 180 rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) ) !0 if no ice and 1 if yes 165 181 ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 166 182 o_i(ji,jj,jl) = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch … … 168 184 END DO 169 185 END DO 170 186 171 187 IF( nn_icesal == 2 )THEN 172 188 DO jl = 1, jpl -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90
r5517 r6455 157 157 ENDIF 158 158 159 IF ( iom_use( "icecolf" ) ) THEN 160 DO jj = 1, jpj 161 DO ji = 1, jpi 162 rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 163 z2d(ji,jj) = hicol(ji,jj) * rswitch 164 END DO 165 END DO 166 CALL iom_put( "icecolf" , z2d ) ! frazil ice collection thickness 167 ENDIF 159 IF ( iom_use( "icecolf" ) ) CALL iom_put( "icecolf", hicol ) ! frazil ice collection thickness 168 160 169 161 CALL iom_put( "isst" , sst_m ) ! sea surface temperature … … 190 182 CALL iom_put( "destrp" , diag_trp_es ) ! advected snw enthalpy (W/m2) 191 183 192 CALL iom_put( "sfxbog" , sfx_bog * rday ) ! salt flux from b rines193 CALL iom_put( "sfxbom" , sfx_bom * rday ) ! salt flux from b rines194 CALL iom_put( "sfxsum" , sfx_sum * rday ) ! salt flux from brines195 CALL iom_put( "sfxsni" , sfx_sni * rday ) ! salt flux from brines196 CALL iom_put( "sfxopw" , sfx_opw * rday ) ! salt flux from brines184 CALL iom_put( "sfxbog" , sfx_bog * rday ) ! salt flux from bottom growth 185 CALL iom_put( "sfxbom" , sfx_bom * rday ) ! salt flux from bottom melt 186 CALL iom_put( "sfxsum" , sfx_sum * rday ) ! salt flux from surface melt 187 CALL iom_put( "sfxsni" , sfx_sni * rday ) ! salt flux from snow ice formation 188 CALL iom_put( "sfxopw" , sfx_opw * rday ) ! salt flux from open water formation 197 189 CALL iom_put( "sfxdyn" , sfx_dyn * rday ) ! salt flux from ridging rafting 198 CALL iom_put( "sfxres" , sfx_res * rday ) ! salt flux from limupdate (resultant)190 CALL iom_put( "sfxres" , sfx_res * rday ) ! salt flux from residual 199 191 CALL iom_put( "sfxbri" , sfx_bri * rday ) ! salt flux from brines 192 CALL iom_put( "sfxsub" , sfx_sub * rday ) ! salt flux from sublimation 200 193 CALL iom_put( "sfx" , sfx * rday ) ! total salt flux 201 194 … … 235 228 CALL iom_put ('hfxdhc' , diag_heat(:,:) ) ! Heat content variation in snow and ice 236 229 CALL iom_put ('hfxspr' , hfx_spr(:,:) ) ! Heat content of snow precip 230 231 232 IF ( iom_use( "vfxthin" ) ) THEN ! ice production for open water + thin ice (<20cm) => comparable to observations 233 DO jj = 1, jpj 234 DO ji = 1, jpi 235 z2d(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) ! mean ice thickness 236 END DO 237 END DO 238 WHERE( z2d(:,:) < 0.2 .AND. z2d(:,:) > 0. ) ; z2da = wfx_bog 239 ELSEWHERE ; z2da = 0._wp 240 END WHERE 241 CALL iom_put( "vfxthin", ( wfx_opw + z2da ) * ztmp ) 242 ENDIF 237 243 238 244 !-------------------------------- … … 311 317 !! 312 318 !! History : 313 !! 4. 1! 2013-06 (C. Rousset)319 !! 4.0 ! 2013-06 (C. Rousset) 314 320 !!---------------------------------------------------------------------- 315 321 INTEGER, INTENT( in ) :: kt ! ocean time-step index) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90
r5407 r6455 45 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qns_ice_1d 46 46 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: t_bo_1d 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: rn_amax_1d 47 48 48 49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: hfx_sum_1d … … 83 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_res_1d 84 85 86 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sfx_sub_1d 87 85 88 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: sprecip_1d !: <==> the 2D sprecip 86 89 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: frld_1d !: <==> the 2D frld … … 91 94 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: evap_ice_1d !: <==> the 2D evap_ice 92 95 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qprec_ice_1d !: <==> the 2D qprec_ice 96 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: qevap_ice_1d !: <==> the 3D qevap_ice 93 97 ! ! to reintegrate longwave flux inside the ice thermodynamics 94 98 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: i0 !: fraction of radiation transmitted to the ice … … 107 111 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_s_tot !: Snow accretion/ablation [m] 108 112 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_surf !: Ice surface accretion/ablation [m] 113 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_sub !: Ice surface sublimation [m] 109 114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_i_bott !: Ice bottom accretion/ablation [m] 110 115 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: dh_snowice !: Snow ice formation [m of ice] … … 144 149 & hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) , & 145 150 & hfx_dif_1d(jpij) , hfx_opw_1d(jpij) , & 151 & rn_amax_1d(jpij) , & 146 152 & hfx_thd_1d(jpij) , hfx_spr_1d(jpij) , & 147 153 & hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) , & … … 153 159 & wfx_sum_1d(jpij) , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) , & 154 160 & dqns_ice_1d(jpij) , evap_ice_1d (jpij), & 155 & qprec_ice_1d(jpij), i0 (jpij) ,&161 & qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0 (jpij) , & 156 162 & sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij), & 157 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , 163 & sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij), & 158 164 & dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) , & 159 165 & dsm_i_si_1d(jpij) , hicol_1d (jpij) , STAT=ierr(2) ) … … 161 167 ALLOCATE( t_su_1d (jpij) , a_i_1d (jpij) , ht_i_1d (jpij) , & 162 168 & ht_s_1d (jpij) , fc_su (jpij) , fc_bo_i (jpij) , & 163 & dh_s_tot (jpij) , dh_i_surf(jpij) , dh_i_ bott(jpij) , &164 & dh_ snowice(jpij) , sm_i_1d (jpij) , s_i_new (jpij) , &169 & dh_s_tot (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) , & 170 & dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d (jpij) , s_i_new (jpij) , & 165 171 & t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) , & 166 172 & q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) , & -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r6204 r6455 145 145 ENDIF 146 146 147 IF( .NOT.lk_vvl ) THEN 148 CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 149 CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 150 CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 151 CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 152 ENDIF 147 ! Output of initial vertical scale factor 148 CALL iom_put("e3t_0", e3t_0(:,:,:) ) 149 CALL iom_put("e3u_0", e3t_0(:,:,:) ) 150 CALL iom_put("e3v_0", e3t_0(:,:,:) ) 151 ! 152 CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 153 CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 154 CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 155 CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 156 IF( iom_use("e3tdef") ) & 157 CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 158 153 159 154 160 CALL iom_put( "ssh" , sshn ) ! sea surface height 155 if( iom_use('ssh2') ) CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) ) ! square of sea surface height156 161 157 162 CALL iom_put( "toce", tsn(:,:,:,jp_tem) ) ! 3D temperature … … 243 248 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 244 249 CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. (useful only with key_zdfddm) 250 ! Log of eddy diff coef 251 IF( iom_use('logavt') ) CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt (:,:,:) ) ) ) 252 IF( iom_use('logavs') ) CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 245 253 246 254 IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN … … 307 315 CALL iom_put( "eken", rke ) 308 316 ENDIF 309 317 ! 318 CALL iom_put( "hdiv", hdivn ) ! Horizontal divergence 319 ! 310 320 IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 311 321 z3d(:,:,jpk) = 0.e0 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r5506 r6455 665 665 ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 666 666 END DO 667 668 ! Write outputs669 ! =============670 CALL iom_put( "e3t" , fse3t_n (:,:,:) )671 CALL iom_put( "e3u" , fse3u_n (:,:,:) )672 CALL iom_put( "e3v" , fse3v_n (:,:,:) )673 CALL iom_put( "e3w" , fse3w_n (:,:,:) )674 CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) )675 IF( iom_use("e3tdef") ) &676 CALL iom_put( "e3tdef" , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 )677 667 678 668 ! write restart file -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r6204 r6455 139 139 ! horizontal grid definition 140 140 141 #if ! defined key_xios2142 141 CALL set_scalar 143 #endif144 142 145 143 IF( TRIM(cdname) == TRIM(cxios_context) ) THEN … … 1193 1191 REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue 1194 1192 REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) :: bounds_lon, bounds_lat, area 1195 LOGICAL, DIMENSION(:,:) , OPTIONAL, INTENT(in) :: mask 1193 #if ! defined key_xios2 1194 LOGICAL, DIMENSION(:,:) , OPTIONAL, INTENT(in) :: mask 1195 #else 1196 LOGICAL, DIMENSION(:) , OPTIONAL, INTENT(in) :: mask 1197 #endif 1196 1198 1197 1199 #if ! defined key_xios2 … … 1215 1217 CALL xios_set_domain_attr ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1216 1218 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1217 & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_ 2D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,&1219 & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & 1218 1220 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 1219 1221 ENDIF … … 1221 1223 CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj, & 1222 1224 & data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj , & 1223 & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_ 2D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,&1225 & lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon, & 1224 1226 & bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 1225 1227 ENDIF … … 1234 1236 INTEGER , OPTIONAL, INTENT(in) :: ibegin, jbegin, ni, nj 1235 1237 1236 IF ( xios_is_valid_ domain (cdid) ) THEN1238 IF ( xios_is_valid_zoom_domain (cdid) ) THEN 1237 1239 CALL xios_set_zoom_domain_attr ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni, & 1238 1240 & nj=nj) … … 1326 1328 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask=mask ) 1327 1329 #else 1328 IF ( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask 3=mask )1329 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask 3=mask )1330 IF ( xios_is_valid_grid (cdid) ) CALL xios_set_grid_attr ( cdid, mask_3D=mask ) 1331 IF ( xios_is_valid_gridgroup(cdid) ) CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 1330 1332 #endif 1331 1333 CALL xios_solve_inheritance() … … 1388 1390 END SELECT 1389 1391 ! 1392 #if ! defined key_xios2 1390 1393 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj /)) /= 0. ) 1394 #else 1395 CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj /)) /= 0. ) 1396 #endif 1391 1397 CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 1392 1398 ENDIF … … 1532 1538 #else 1533 1539 ! Pas teste : attention aux indices ! 1534 CALL iom_set_domain_attr(" ptr", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj)1535 CALL iom_set_domain_attr(" ptr", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj)1536 CALL iom_set_domain_attr(" ptr", lonvalue = zlon, &1540 CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 1541 CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 1542 CALL iom_set_domain_attr("gznl", lonvalue = zlon, & 1537 1543 & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) 1538 CALL iom_set_zoom_domain_attr ( 'ptr', ibegin=ix, nj=jpjglo)1544 CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 1539 1545 #endif 1540 1546 … … 1552 1558 REAL(wp), DIMENSION(1) :: zz = 1. 1553 1559 !!---------------------------------------------------------------------- 1560 #if ! defined key_xios2 1554 1561 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 1562 #else 1563 CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 1564 #endif 1555 1565 CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 1556 1566 … … 1778 1788 idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 1779 1789 DO WHILE ( idx /= 0 ) 1780 IF ( output_freq%hour /= 0 ) THEN 1790 IF ( output_freq%timestep /= 0) THEN 1791 WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts' 1792 itrlen = LEN_TRIM(ADJUSTL(clfreq)) 1793 ELSE IF ( output_freq%hour /= 0 ) THEN 1781 1794 WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h' 1782 1795 itrlen = LEN_TRIM(ADJUSTL(clfreq)) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90
r4679 r6455 201 201 202 202 #endif 203 IF(lwp) THEN204 WRITE(numout,*)205 WRITE(numout,*) ' defines mpp subdomains'206 WRITE(numout,*) ' ----------------------'207 WRITE(numout,*) ' iresti=',iresti,' irestj=',irestj208 WRITE(numout,*) ' jpni =',jpni ,' jpnj =',jpnj209 ifreq = 4210 il1 = 1211 DO jn = 1, (jpni-1)/ifreq+1212 il2 = MIN( jpni, il1+ifreq-1 )213 WRITE(numout,*)214 WRITE(numout,9200) ('***',ji = il1,il2-1)215 DO jj = jpnj, 1, -1216 WRITE(numout,9203) (' ',ji = il1,il2-1)217 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 )218 WRITE(numout,9203) (' ',ji = il1,il2-1)219 WRITE(numout,9200) ('***',ji = il1,il2-1)220 END DO221 WRITE(numout,9201) (ji,ji = il1,il2)222 il1 = il1+ifreq223 END DO224 9200 FORMAT(' ***',20('*************',a3))225 9203 FORMAT(' * ',20(' * ',a3))226 9201 FORMAT(' ',20(' ',i3,' '))227 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * '))228 ENDIF229 230 zidom = nreci231 DO ji = 1, jpni232 zidom = zidom + ilcit(ji,1) - nreci233 END DO234 IF(lwp) WRITE(numout,*)235 IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo236 237 zjdom = nrecj238 DO jj = 1, jpnj239 zjdom = zjdom + ilcjt(1,jj) - nrecj240 END DO241 IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo242 IF(lwp) WRITE(numout,*)243 244 203 245 204 ! 2. Index arrays for subdomains … … 304 263 nlejt(jn) = nlej 305 264 END DO 306 307 308 ! 4. From global to local 265 266 ! 4. Subdomain print 267 ! ------------------ 268 269 IF(lwp) WRITE(numout,*) 270 IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 271 IF(lwp) WRITE(numout,*) ' ~~~~~~ ----------------------' 272 IF(lwp) WRITE(numout,*) 273 IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 274 IF(lwp) WRITE(numout,*) 275 IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 276 zidom = nreci 277 DO ji = 1, jpni 278 zidom = zidom + ilcit(ji,1) - nreci 279 END DO 280 IF(lwp) WRITE(numout,*) 281 IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 282 283 zjdom = nrecj 284 DO jj = 1, jpnj 285 zjdom = zjdom + ilcjt(1,jj) - nrecj 286 END DO 287 IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 288 IF(lwp) WRITE(numout,*) 289 290 IF(lwp) THEN 291 ifreq = 4 292 il1 = 1 293 DO jn = 1, (jpni-1)/ifreq+1 294 il2 = MIN( jpni, il1+ifreq-1 ) 295 WRITE(numout,*) 296 WRITE(numout,9200) ('***',ji = il1,il2-1) 297 DO jj = jpnj, 1, -1 298 WRITE(numout,9203) (' ',ji = il1,il2-1) 299 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 300 WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 301 WRITE(numout,9203) (' ',ji = il1,il2-1) 302 WRITE(numout,9200) ('***',ji = il1,il2-1) 303 END DO 304 WRITE(numout,9201) (ji,ji = il1,il2) 305 il1 = il1+ifreq 306 END DO 307 9200 FORMAT(' ***',20('*************',a3)) 308 9203 FORMAT(' * ',20(' * ',a3)) 309 9201 FORMAT(' ',20(' ',i3,' ')) 310 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ')) 311 9204 FORMAT(' * ',20(' ',i3,' * ')) 312 ENDIF 313 314 ! 5. From global to local 309 315 ! ----------------------- 310 316 … … 313 319 314 320 315 ! 5. Subdomain neighbours321 ! 6. Subdomain neighbours 316 322 ! ---------------------- 317 323 … … 436 442 WRITE(numout,*) ' nimpp = ', nimpp 437 443 WRITE(numout,*) ' njmpp = ', njmpp 438 WRITE(numout,*) ' nbse = ', nbse , ' npse = ', npse 439 WRITE(numout,*) ' nbsw = ', nbsw , ' npsw = ', npsw 440 WRITE(numout,*) ' nbne = ', nbne , ' npne = ', npne 441 WRITE(numout,*) ' nbnw = ', nbnw , ' npnw = ', npnw 444 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 445 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 446 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 447 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 448 WRITE(numout,*) 442 449 ENDIF 443 450 … … 446 453 ! Prepare mpp north fold 447 454 448 IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN455 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 449 456 CALL mpp_ini_north 450 END IF 457 IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 458 ENDIF 451 459 452 460 ! Prepare NetCDF output file (if necessary) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90
r5130 r6455 318 318 ENDIF 319 319 320 ! Check wet points over the entire domain to preserve the MPI communication stencil 320 321 isurf = 0 321 DO jj = 1 +jprecj, ilj-jprecj322 DO ji = 1 +jpreci, ili-jpreci322 DO jj = 1, ilj 323 DO ji = 1, ili 323 324 IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 324 325 END DO 325 326 END DO 327 326 328 IF(isurf /= 0) THEN 327 329 icont = icont + 1 … … 333 335 334 336 nfipproc(:,:) = ipproc(:,:) 335 336 337 337 338 ! Control … … 441 442 ii = iin(narea) 442 443 ij = ijn(narea) 444 445 ! set default neighbours 446 noso = ioso(ii,ij) 447 nowe = iowe(ii,ij) 448 noea = ioea(ii,ij) 449 nono = iono(ii,ij) 450 npse = iose(ii,ij) 451 npsw = iosw(ii,ij) 452 npne = ione(ii,ij) 453 npnw = ionw(ii,ij) 454 455 ! check neighbours location 443 456 IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 444 457 iiso = 1 + MOD(ioso(ii,ij),jpni) … … 511 524 IF (lwp) THEN 512 525 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 526 WRITE(inum,'(a)') ' jpnij jpi jpj jpk jpiglo jpjglo' 513 527 WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 514 528 WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' … … 523 537 END IF 524 538 525 IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' )526 527 ! Prepare mpp north fold528 529 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN530 CALL mpp_ini_north531 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1'532 ENDIF533 534 539 ! Defined npolj, either 0, 3 , 4 , 5 , 6 535 540 ! In this case the important thing is that npolj /= 0 … … 548 553 ENDIF 549 554 555 ! Periodicity : no corner if nbondi = 2 and nperio != 1 556 557 IF(lwp) THEN 558 WRITE(numout,*) ' nproc = ', nproc 559 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 560 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 561 WRITE(numout,*) ' nbondi = ', nbondi 562 WRITE(numout,*) ' nbondj = ', nbondj 563 WRITE(numout,*) ' npolj = ', npolj 564 WRITE(numout,*) ' nperio = ', nperio 565 WRITE(numout,*) ' nlci = ', nlci 566 WRITE(numout,*) ' nlcj = ', nlcj 567 WRITE(numout,*) ' nimpp = ', nimpp 568 WRITE(numout,*) ' njmpp = ', njmpp 569 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 570 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 571 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 572 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 573 WRITE(numout,*) 574 ENDIF 575 576 IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 577 578 ! Prepare mpp north fold 579 580 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 581 CALL mpp_ini_north 582 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 583 ENDIF 584 550 585 ! Prepare NetCDF output file (if necessary) 551 586 CALL mpp_init_ioipsl 552 587 553 ! Periodicity : no corner if nbondi = 2 and nperio != 1554 555 IF(lwp) THEN556 WRITE(numout,*) ' nproc= ',nproc557 WRITE(numout,*) ' nowe= ',nowe558 WRITE(numout,*) ' noea= ',noea559 WRITE(numout,*) ' nono= ',nono560 WRITE(numout,*) ' noso= ',noso561 WRITE(numout,*) ' nbondi= ',nbondi562 WRITE(numout,*) ' nbondj= ',nbondj563 WRITE(numout,*) ' npolj= ',npolj564 WRITE(numout,*) ' nperio= ',nperio565 WRITE(numout,*) ' nlci= ',nlci566 WRITE(numout,*) ' nlcj= ',nlcj567 WRITE(numout,*) ' nimpp= ',nimpp568 WRITE(numout,*) ' njmpp= ',njmpp569 WRITE(numout,*) ' nbse= ',nbse,' npse= ',npse570 WRITE(numout,*) ' nbsw= ',nbsw,' npsw= ',npsw571 WRITE(numout,*) ' nbne= ',nbne,' npne= ',npne572 WRITE(numout,*) ' nbnw= ',nbnw,' npnw= ',npnw573 ENDIF574 588 575 589 END SUBROUTINE mpp_init2 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r5120 r6455 188 188 DO jj = 2, jpjm1 189 189 DO ji = fs_2, fs_jpim1 ! vector opt. 190 IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji ,jj ), 5._wp) 191 IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj ), 5._wp) 192 IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji ,jj ), hmlpt(ji+1,jj ), 5._wp) 193 IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj ), 5._wp) 194 IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj+1), 5._wp) 195 IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji ,jj ), hmlpt(ji ,jj+1), 5._wp) 190 zhmlpu(ji,jj) = ( MAX(hmlpt(ji,jj) , hmlpt (ji+1,jj ), 5._wp) & 191 & - MAX(risfdep(ji,jj), risfdep(ji+1,jj ) ) ) 192 zhmlpv(ji,jj) = ( MAX(hmlpt (ji,jj), hmlpt (ji ,jj+1), 5._wp) & 193 & - MAX(risfdep(ji,jj), risfdep(ji ,jj+1) ) ) 196 194 ENDDO 197 195 ENDDO -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90
r4147 r6455 41 41 42 42 REAL(wp), PUBLIC :: rldf !: multiplicative factor of diffusive coefficient 43 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: r_fact_lap 43 44 !: Needed to define the ratio between passive and active tracer diffusion coef. 44 45 … … 92 93 !! *** FUNCTION ldftra_oce_alloc *** 93 94 !!---------------------------------------------------------------------- 94 INTEGER, DIMENSION( 3) :: ierr95 INTEGER, DIMENSION(4) :: ierr 95 96 !!---------------------------------------------------------------------- 96 97 ierr(:) = 0 … … 116 117 # endif 117 118 #endif 119 ALLOCATE( r_fact_lap(jpi,jpj,jpk), STAT=ierr(4) ) 118 120 ldftra_oce_alloc = MAXVAL( ierr ) 119 121 IF( ldftra_oce_alloc /= 0 ) CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_substitute.h90
r3294 r6455 13 13 ! 'key_traldf_c3d' : aht: 3D coefficient 14 14 # define fsahtt(i,j,k) rldf * ahtt(i,j,k) 15 # define fsahtu(i,j,k) rldf * ahtu(i,j,k) 15 # define fsahtu(i,j,k) rldf * ahtu(i,j,k) * r_fact_lap(i,j,k) 16 16 # define fsahtv(i,j,k) rldf * ahtv(i,j,k) 17 17 # define fsahtw(i,j,k) rldf * ahtw(i,j,k) … … 19 19 ! 'key_traldf_c2d' : aht: 2D coefficient 20 20 # define fsahtt(i,j,k) rldf * ahtt(i,j) 21 # define fsahtu(i,j,k) rldf * ahtu(i,j) 21 # define fsahtu(i,j,k) rldf * ahtu(i,j) * r_fact_lap(i,j,k) 22 22 # define fsahtv(i,j,k) rldf * ahtv(i,j) 23 23 # define fsahtw(i,j,k) rldf * ahtw(i,j) … … 25 25 ! 'key_traldf_c1d' : aht: 1D coefficient 26 26 # define fsahtt(i,j,k) rldf * ahtt(k) 27 # define fsahtu(i,j,k) rldf * ahtu(k) 27 # define fsahtu(i,j,k) rldf * ahtu(k) * r_fact_lap(i,j,k) 28 28 # define fsahtv(i,j,k) rldf * ahtv(k) 29 29 # define fsahtw(i,j,k) rldf * ahtw(k) … … 31 31 ! Default option : aht: Constant coefficient 32 32 # define fsahtt(i,j,k) rldf * aht0 33 # define fsahtu(i,j,k) rldf * aht0 33 # define fsahtu(i,j,k) rldf * aht0 * r_fact_lap(i,j,k) 34 34 # define fsahtv(i,j,k) rldf * aht0 35 35 # define fsahtw(i,j,k) rldf * aht0 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90
r4624 r6455 9 9 !! - ! 2001-06 (M. Vancoppenolle) LIM 3.0 10 10 !! - ! 2006-08 (G. Madec) cleaning for surface module 11 !! 3.6 ! 2016-01 (C. Rousset) new parameterization for sea ice albedo 11 12 !!---------------------------------------------------------------------- 12 13 … … 29 30 30 31 INTEGER :: albd_init = 0 !: control flag for initialization 31 REAL(wp) :: zzero = 0.e0 ! constant values32 REAL(wp) :: zone = 1.e0 ! " "33 34 REAL(wp) :: c1 = 0.05 ! constants values35 REAL(wp) :: c2 = 0.10 !" "36 REAL(wp) :: r mue = 0.40 ! cosine of local solar altitude37 32 33 REAL(wp) :: rmue = 0.40 ! cosine of local solar altitude 34 REAL(wp) :: ralb_oce = 0.066 ! ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 35 REAL(wp) :: c1 = 0.05 ! snow thickness (only for nn_ice_alb=0) 36 REAL(wp) :: c2 = 0.10 ! " " 37 REAL(wp) :: rcloud = 0.06 ! cloud effect on albedo (only-for nn_ice_alb=0) 38 38 39 ! !!* namelist namsbc_alb 39 REAL(wp) :: rn_cloud ! cloudiness effect on snow or ice albedo (Grenfell & Perovich, 1984) 40 #if defined key_lim3 41 REAL(wp) :: rn_albice ! albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 42 #else 43 REAL(wp) :: rn_albice ! albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 44 #endif 45 REAL(wp) :: rn_alphd ! coefficients for linear interpolation used to compute 46 REAL(wp) :: rn_alphdi ! albedo between two extremes values (Pyane, 1972) 47 REAL(wp) :: rn_alphc ! 40 INTEGER :: nn_ice_alb 41 REAL(wp) :: rn_albice 48 42 49 43 !!---------------------------------------------------------------------- … … 59 53 !! 60 54 !! ** Purpose : Computation of the albedo of the snow/ice system 61 !! as well as the ocean one62 55 !! 63 !! ** Method : - Computation of the albedo of snow or ice (choose the 64 !! rignt one by a large number of tests 65 !! - Computation of the albedo of the ocean 66 !! 67 !! References : Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 56 !! ** Method : Two schemes are available (from namelist parameter nn_ice_alb) 57 !! 0: the scheme is that of Shine & Henderson-Sellers (JGR 1985) for clear-skies 58 !! 1: the scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) 59 !! and Grenfell & Perovich (JGR 2004) 60 !! Description of scheme 1: 61 !! 1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) 62 !! which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 63 !! 0-5cm : linear function of ice thickness 64 !! 5-150cm: log function of ice thickness 65 !! > 150cm: constant 66 !! 2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) 67 !! i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting 68 !! 3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) 69 !! i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law 70 !! 4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice 71 !! 72 !! ** Note : The parameterization from Shine & Henderson-Sellers presents several misconstructions: 73 !! 1) ice albedo when ice thick. tends to 0 is different than ocean albedo 74 !! 2) for small ice thick. covered with some snow (<3cm?), albedo is larger 75 !! under melting conditions than under freezing conditions 76 !! 3) the evolution of ice albedo as a function of ice thickness shows 77 !! 3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic 78 !! 79 !! References : Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. 80 !! Brandt et al. 2005, J. Climate, vol 18 81 !! Grenfell & Perovich 2004, JGR, vol 109 68 82 !!---------------------------------------------------------------------- 69 83 REAL(wp), INTENT(in ), DIMENSION(:,:,:) :: pt_ice ! ice surface temperature (Kelvin) … … 73 87 REAL(wp), INTENT( out), DIMENSION(:,:,:) :: pa_ice_os ! albedo of ice under overcast sky 74 88 !! 75 INTEGER :: ji, jj, jl ! dummy loop indices 76 INTEGER :: ijpl ! number of ice categories (3rd dim of ice input arrays) 77 REAL(wp) :: zalbpsnm ! albedo of ice under clear sky when snow is melting 78 REAL(wp) :: zalbpsnf ! albedo of ice under clear sky when snow is freezing 79 REAL(wp) :: zalbpsn ! albedo of snow/ice system when ice is coverd by snow 80 REAL(wp) :: zalbpic ! albedo of snow/ice system when ice is free of snow 81 REAL(wp) :: zithsn ! = 1 for hsn >= 0 ( ice is cov. by snow ) ; = 0 otherwise (ice is free of snow) 82 REAL(wp) :: zitmlsn ! = 1 freezinz snow (pt_ice >=rt0_snow) ; = 0 melting snow (pt_ice<rt0_snow) 83 REAL(wp) :: zihsc1 ! = 1 hsn <= c1 ; = 0 hsn > c1 84 REAL(wp) :: zihsc2 ! = 1 hsn >= c2 ; = 0 hsn < c2 85 !! 86 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalbfz ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 87 REAL(wp), POINTER, DIMENSION(:,:,:) :: zficeth ! function of ice thickness 89 INTEGER :: ji, jj, jl ! dummy loop indices 90 INTEGER :: ijpl ! number of ice categories (3rd dim of ice input arrays) 91 REAL(wp) :: ralb_im, ralb_sf, ralb_sm, ralb_if 92 REAL(wp) :: zswitch, z1_c1, z1_c2 93 REAL(wp) :: zalb_sm, zalb_sf, zalb_st ! albedo of snow melting, freezing, total 94 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb, zalb_it ! intermediate variable & albedo of ice (snow free) 88 95 !!--------------------------------------------------------------------- 89 96 90 97 ijpl = SIZE( pt_ice, 3 ) ! number of ice categories 91 92 CALL wrk_alloc( jpi,jpj,ijpl, zalb fz, zficeth)98 99 CALL wrk_alloc( jpi,jpj,ijpl, zalb, zalb_it ) 93 100 94 101 IF( albd_init == 0 ) CALL albedo_init ! initialization 95 102 96 !--------------------------- 97 ! Computation of zficeth 98 !--------------------------- 99 ! ice free of snow and melts 100 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalbfz(:,:,:) = rn_albice 101 ELSE WHERE ; zalbfz(:,:,:) = rn_alphdi 102 END WHERE 103 104 WHERE ( 1.5 < ph_ice ) ; zficeth = zalbfz 105 ELSE WHERE( 1.0 < ph_ice .AND. ph_ice <= 1.5 ) ; zficeth = 0.472 + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 106 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 ) ; zficeth = 0.2467 + 0.7049 * ph_ice & 107 & - 0.8608 * ph_ice * ph_ice & 108 & + 0.3812 * ph_ice * ph_ice * ph_ice 109 ELSE WHERE ; zficeth = 0.1 + 3.6 * ph_ice 110 END WHERE 111 112 !!gm old code 113 ! DO jl = 1, ijpl 114 ! DO jj = 1, jpj 115 ! DO ji = 1, jpi 116 ! IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 117 ! zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 118 ! ELSEIF( ph_ice(ji,jj,jl) > 1.0 .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 119 ! zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 120 ! ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 121 ! zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl) & 122 ! & - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) & 123 ! & + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 124 ! ELSE 125 ! zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl) 126 ! ENDIF 127 ! END DO 128 ! END DO 129 ! END DO 130 !!gm end old code 131 132 !----------------------------------------------- 133 ! Computation of the snow/ice albedo system 134 !-------------------------- --------------------- 135 136 ! Albedo of snow-ice for clear sky. 137 !----------------------------------------------- 138 DO jl = 1, ijpl 139 DO jj = 1, jpj 140 DO ji = 1, jpi 141 ! Case of ice covered by snow. 142 ! ! freezing snow 143 zihsc1 = 1.0 - MAX( zzero , SIGN( zone , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 144 zalbpsnf = ( 1.0 - zihsc1 ) * ( zficeth(ji,jj,jl) & 145 & + ph_snw(ji,jj,jl) * ( rn_alphd - zficeth(ji,jj,jl) ) / c1 ) & 146 & + zihsc1 * rn_alphd 147 ! ! melting snow 148 zihsc2 = MAX( zzero , SIGN( zone , ph_snw(ji,jj,jl) - c2 ) ) 149 zalbpsnm = ( 1.0 - zihsc2 ) * ( rn_albice + ph_snw(ji,jj,jl) * ( rn_alphc - rn_albice ) / c2 ) & 150 & + zihsc2 * rn_alphc 151 ! 152 zitmlsn = MAX( zzero , SIGN( zone , pt_ice(ji,jj,jl) - rt0_snow ) ) 153 zalbpsn = zitmlsn * zalbpsnm + ( 1.0 - zitmlsn ) * zalbpsnf 154 155 ! Case of ice free of snow. 156 zalbpic = zficeth(ji,jj,jl) 157 158 ! albedo of the system 159 zithsn = 1.0 - MAX( zzero , SIGN( zone , - ph_snw(ji,jj,jl) ) ) 160 pa_ice_cs(ji,jj,jl) = zithsn * zalbpsn + ( 1.0 - zithsn ) * zalbpic 103 104 SELECT CASE ( nn_ice_alb ) 105 106 !------------------------------------------ 107 ! Shine and Henderson-Sellers (1985) 108 !------------------------------------------ 109 CASE( 0 ) 110 111 ralb_sf = 0.80 ! dry snow 112 ralb_sm = 0.65 ! melting snow 113 ralb_if = 0.72 ! bare frozen ice 114 ralb_im = rn_albice ! bare puddled ice 115 116 ! Computation of ice albedo (free of snow) 117 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalb(:,:,:) = ralb_im 118 ELSE WHERE ; zalb(:,:,:) = ralb_if 119 END WHERE 120 121 WHERE ( 1.5 < ph_ice ) ; zalb_it = zalb 122 ELSE WHERE( 1.0 < ph_ice .AND. ph_ice <= 1.5 ) ; zalb_it = 0.472 + 2.0 * ( zalb - 0.472 ) * ( ph_ice - 1.0 ) 123 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 ) ; zalb_it = 0.2467 + 0.7049 * ph_ice & 124 & - 0.8608 * ph_ice * ph_ice & 125 & + 0.3812 * ph_ice * ph_ice * ph_ice 126 ELSE WHERE ; zalb_it = 0.1 + 3.6 * ph_ice 127 END WHERE 128 129 DO jl = 1, ijpl 130 DO jj = 1, jpj 131 DO ji = 1, jpi 132 ! freezing snow 133 ! no effect of underlying ice layer IF snow thickness > c1. Albedo does not depend on snow thick if > c2 134 ! ! freezing snow 135 zswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 136 zalb_sf = ( 1._wp - zswitch ) * ( zalb_it(ji,jj,jl) & 137 & + ph_snw(ji,jj,jl) * ( ralb_sf - zalb_it(ji,jj,jl) ) / c1 ) & 138 & + zswitch * ralb_sf 139 140 ! melting snow 141 ! no effect of underlying ice layer. Albedo does not depend on snow thick IF > c2 142 zswitch = MAX( 0._wp , SIGN( 1._wp , ph_snw(ji,jj,jl) - c2 ) ) 143 zalb_sm = ( 1._wp - zswitch ) * ( ralb_im + ph_snw(ji,jj,jl) * ( ralb_sm - ralb_im ) / c2 ) & 144 & + zswitch * ralb_sm 145 ! 146 ! snow albedo 147 zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) ) 148 zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 149 150 ! Ice/snow albedo 151 zswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 152 pa_ice_cs(ji,jj,jl) = zswitch * zalb_st + ( 1._wp - zswitch ) * zalb_it(ji,jj,jl) 153 ! 154 END DO 161 155 END DO 162 156 END DO 163 END DO 164 165 ! Albedo of snow-ice for overcast sky. 166 !---------------------------------------------- 167 pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud ! Oberhuber correction 168 ! 169 CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 157 158 pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rcloud ! Oberhuber correction for overcast sky 159 160 !------------------------------------------ 161 ! New parameterization (2016) 162 !------------------------------------------ 163 CASE( 1 ) 164 165 ralb_im = rn_albice ! bare puddled ice 166 ! compilation of values from literature 167 ralb_sf = 0.85 ! dry snow 168 ralb_sm = 0.75 ! melting snow 169 ralb_if = 0.60 ! bare frozen ice 170 ! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 171 ! ralb_sf = 0.85 ! dry snow 172 ! ralb_sm = 0.72 ! melting snow 173 ! ralb_if = 0.65 ! bare frozen ice 174 ! Brandt et al 2005 (East Antarctica) 175 ! ralb_sf = 0.87 ! dry snow 176 ! ralb_sm = 0.82 ! melting snow 177 ! ralb_if = 0.54 ! bare frozen ice 178 ! 179 ! Computation of ice albedo (free of snow) 180 z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) ) 181 z1_c2 = 1. / 0.05 182 WHERE ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice ) ; zalb = ralb_im 183 ELSE WHERE ; zalb = ralb_if 184 END WHERE 185 186 WHERE ( 1.5 < ph_ice ) ; zalb_it = zalb 187 ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.5 ) ; zalb_it = zalb + ( 0.18 - zalb ) * z1_c1 * & 188 & ( LOG(1.5) - LOG(ph_ice) ) 189 ELSE WHERE ; zalb_it = ralb_oce + ( 0.18 - ralb_oce ) * z1_c2 * ph_ice 190 END WHERE 191 192 z1_c1 = 1. / 0.02 193 z1_c2 = 1. / 0.03 194 ! Computation of the snow/ice albedo 195 DO jl = 1, ijpl 196 DO jj = 1, jpj 197 DO ji = 1, jpi 198 zalb_sf = ralb_sf - ( ralb_sf - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c1 ); 199 zalb_sm = ralb_sm - ( ralb_sm - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c2 ); 200 201 ! snow albedo 202 zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) ) 203 zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 204 205 ! Ice/snow albedo 206 zswitch = MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 207 pa_ice_os(ji,jj,jl) = ( 1._wp - zswitch ) * zalb_st + zswitch * zalb_it(ji,jj,jl) 208 209 END DO 210 END DO 211 END DO 212 ! Effect of the clouds (2d order polynomial) 213 pa_ice_cs = pa_ice_os - ( - 0.1010 * pa_ice_os * pa_ice_os + 0.1933 * pa_ice_os - 0.0148 ); 214 215 END SELECT 216 217 CALL wrk_dealloc( jpi,jpj,ijpl, zalb, zalb_it ) 170 218 ! 171 219 END SUBROUTINE albedo_ice … … 181 229 REAL(wp), DIMENSION(:,:), INTENT(out) :: pa_oce_cs ! albedo of ocean under clear sky 182 230 !! 183 REAL(wp) :: zcoef ! local scalar184 !!---------------------------------------------------------------------- 185 ! 186 zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982187 pa_oce_cs(:,:) = zcoef 188 pa_oce_os(:,:) = 0.06! Parameterization of Kondratyev, 1969 and Payne, 1972231 REAL(wp) :: zcoef 232 !!---------------------------------------------------------------------- 233 ! 234 zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 ) ! Parameterization of Briegled and Ramanathan, 1982 235 pa_oce_cs(:,:) = zcoef 236 pa_oce_os(:,:) = 0.06 ! Parameterization of Kondratyev, 1969 and Payne, 1972 189 237 ! 190 238 END SUBROUTINE albedo_oce … … 200 248 !!---------------------------------------------------------------------- 201 249 INTEGER :: ios ! Local integer output status for namelist read 202 NAMELIST/namsbc_alb/ rn_cloud, rn_albice, rn_alphd, rn_alphdi, rn_alphc250 NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice 203 251 !!---------------------------------------------------------------------- 204 252 ! … … 219 267 WRITE(numout,*) '~~~~~~~' 220 268 WRITE(numout,*) ' Namelist namsbc_alb : albedo ' 221 WRITE(numout,*) ' correction for snow and ice albedo rn_cloud = ', rn_cloud 222 WRITE(numout,*) ' albedo of melting ice in the arctic and antarctic rn_albice = ', rn_albice 223 WRITE(numout,*) ' coefficients for linear rn_alphd = ', rn_alphd 224 WRITE(numout,*) ' interpolation used to compute albedo rn_alphdi = ', rn_alphdi 225 WRITE(numout,*) ' between two extremes values (Pyane, 1972) rn_alphc = ', rn_alphc 269 WRITE(numout,*) ' choose the albedo parameterization nn_ice_alb = ', nn_ice_alb 270 WRITE(numout,*) ' albedo of bare puddled ice rn_albice = ', rn_albice 226 271 ENDIF 227 272 ! -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90
r5407 r6455 80 80 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_oce !: heat flux of precip and evap over ocean [W/m2] 81 81 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_ice !: heat flux of precip and evap over ice [W/m2] 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: heat flux of precip over ice [J/m3] 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qevap_ice !: heat flux of evap over ice [W/m2] 83 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: enthalpy of precip over ice [J/m3] 83 84 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] 84 85 #endif … … 144 145 #endif 145 146 #if defined key_lim3 146 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , &147 & qemp_ice(jpi,jpj) , qe mp_oce(jpi,jpj) ,&148 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) ,&147 & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) , & 148 & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & 149 & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & 149 150 #endif 150 151 & emp_ice(jpi,jpj) , STAT= ierr(1) ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90
r5487 r6455 684 684 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 685 685 686 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 687 DO jl = 1, jpl 688 qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 689 ! but then qemp_ice should also include sublimation 690 END DO 691 686 692 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) 687 693 #endif -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r5582 r6455 612 612 ! --- evaporation --- ! 613 613 z1_lsub = 1._wp / Lsub 614 evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub! sublimation615 devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub616 zevap (:,:) = emp(:,:) + tprecip(:,:)! evaporation over ocean614 evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub ! sublimation 615 devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub ! d(sublimation)/dT 616 zevap (:,:) = rn_efac * ( emp(:,:) + tprecip(:,:) ) ! evaporation over ocean 617 617 618 618 ! --- evaporation minus precipitation --- ! … … 637 637 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 638 638 qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 639 640 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 641 DO jl = 1, jpl 642 qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 643 ! But we do not have Tice => consider it at 0°C => evap=0 644 END DO 639 645 640 646 CALL wrk_dealloc( jpi,jpj, zevap, zsnw ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r6204 r6455 1378 1378 ! 1379 1379 INTEGER :: jl ! dummy loop index 1380 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk 1381 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, z sprecip, ztprecip, zqns_tot, zqsr_tot1382 REAL(wp), POINTER, DIMENSION(:,: ,:) :: zqns_ice, zqsr_ice, zdqns_ice1383 REAL(wp), POINTER, DIMENSION(:,: ) :: zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM31380 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk, zsnw 1381 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice 1382 REAL(wp), POINTER, DIMENSION(:,: ) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1383 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 1384 1384 !!---------------------------------------------------------------------- 1385 1385 ! 1386 1386 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_ice_flx') 1387 1387 ! 1388 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1389 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1388 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 1389 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 1390 CALL wrk_alloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1391 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 1390 1392 1391 1393 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) … … 1423 1425 END SELECT 1424 1426 1425 IF( iom_use('subl_ai_cea') ) & 1426 CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1427 ! 1428 ! ! runoffs and calving (put in emp_tot) 1427 #if defined key_lim3 1428 ! zsnw = snow percentage over ice after wind blowing 1429 zsnw(:,:) = 0._wp 1430 CALL lim_thd_snwblow( p_frld, zsnw ) 1431 1432 ! --- evaporation (kg/m2/s) --- ! 1433 zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 1434 ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 1435 ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 1436 zdevap_ice(:,:) = 0._wp 1437 1438 ! --- evaporation minus precipitation corrected for the effect of wind blowing on snow --- ! 1439 zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) - zsprecip * (1._wp - zsnw) 1440 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip * (1._wp - zsnw) 1441 1442 ! Sublimation over sea-ice (cell average) 1443 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:) ) 1444 ! runoffs and calving (put in emp_tot) 1445 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1446 IF( srcv(jpr_cal)%laction ) THEN 1447 zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 1448 CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 1449 ENDIF 1450 1451 IF( ln_mixcpl ) THEN 1452 emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 1453 emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 1454 emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 1455 sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 1456 tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 1457 DO jl=1,jpl 1458 evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 1459 devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 1460 ENDDO 1461 ELSE 1462 emp_tot(:,:) = zemp_tot(:,:) 1463 emp_ice(:,:) = zemp_ice(:,:) 1464 emp_oce(:,:) = zemp_oce(:,:) 1465 sprecip(:,:) = zsprecip(:,:) 1466 tprecip(:,:) = ztprecip(:,:) 1467 DO jl=1,jpl 1468 evap_ice (:,:,jl) = zevap_ice (:,:) 1469 devap_ice(:,:,jl) = zdevap_ice(:,:) 1470 ENDDO 1471 ENDIF 1472 1473 CALL iom_put( 'snowpre' , sprecip ) ! Snow 1474 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw ) ) ! Snow over ice-free ocean (cell average) 1475 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zsnw ) ! Snow over sea-ice (cell average) 1476 #else 1477 ! Sublimation over sea-ice (cell average) 1478 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) 1479 ! runoffs and calving (put in emp_tot) 1429 1480 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1430 1481 IF( srcv(jpr_cal)%laction ) THEN … … 1450 1501 IF( iom_use('snow_ai_cea') ) & 1451 1502 CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) ) ! Snow over sea-ice (cell average) 1503 #endif 1452 1504 1453 1505 ! ! ========================= ! … … 1505 1557 IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average) 1506 1558 1507 #if defined key_lim3 1508 CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce ) 1509 1559 #if defined key_lim3 1510 1560 ! --- evaporation --- ! 1511 ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation1512 ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice1513 ! but it is incoherent WITH the ice model1514 DO jl=1,jpl1515 evap_ice(:,:,jl) = 0._wp ! should be: frcv(jpr_ievp)%z3(:,:,1)1516 ENDDO1517 1561 zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 1518 1519 ! --- evaporation minus precipitation --- !1520 emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:)1521 1562 1522 1563 ! --- non solar flux over ocean --- ! … … 1525 1566 WHERE( p_frld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 1526 1567 1527 ! --- heat flux associated with emp --- ! 1528 zsnw(:,:) = 0._wp 1529 CALL lim_thd_snwblow( p_frld, zsnw ) ! snow distribution over ice after wind blowing 1568 ! --- heat flux associated with emp (W/m2) --- ! 1530 1569 zqemp_oce(:,:) = - zevap(:,:) * p_frld(:,:) * zcptn(:,:) & ! evap 1531 1570 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip 1532 1571 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 1533 qemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1534 & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1535 1572 ! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1573 ! & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1574 zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 1575 ! qevap_ice=0 since we consider Tice=0°C 1576 1536 1577 ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 1537 1578 zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 1538 1579 1539 ! --- total non solar flux --- ! 1540 zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 1580 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 1581 DO jl = 1, jpl 1582 zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0°C 1583 END DO 1584 1585 ! --- total non solar flux (including evap/precip) --- ! 1586 zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 1541 1587 1542 1588 ! --- in case both coupled/forced are active, we must mix values --- ! … … 1545 1591 qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 1546 1592 DO jl=1,jpl 1547 qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:) 1593 qns_ice (:,:,jl) = qns_ice (:,:,jl) * xcplmask(:,:,0) + zqns_ice (:,:,jl)* zmsk(:,:) 1594 qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) + zqevap_ice(:,:,jl)* zmsk(:,:) 1548 1595 ENDDO 1549 1596 qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 1550 1597 qemp_oce (:,:) = qemp_oce(:,:) * xcplmask(:,:,0) + zqemp_oce(:,:)* zmsk(:,:) 1551 !!clem evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0)1598 qemp_ice (:,:) = qemp_ice(:,:) * xcplmask(:,:,0) + zqemp_ice(:,:)* zmsk(:,:) 1552 1599 ELSE 1553 1600 qns_tot (:,: ) = zqns_tot (:,: ) 1554 1601 qns_oce (:,: ) = zqns_oce (:,: ) 1555 1602 qns_ice (:,:,:) = zqns_ice (:,:,:) 1556 q prec_ice(:,:) = zqprec_ice(:,:)1557 q emp_oce (:,:) = zqemp_oce (:,:)1558 ENDIF1559 1560 CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )1603 qevap_ice(:,:,:) = zqevap_ice(:,:,:) 1604 qprec_ice(:,: ) = zqprec_ice(:,: ) 1605 qemp_oce (:,: ) = zqemp_oce (:,: ) 1606 qemp_ice (:,: ) = zqemp_ice (:,: ) 1607 ENDIF 1561 1608 #else 1562 1563 1609 ! clem: this formulation is certainly wrong... but better than it was... 1564 1610 zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: … … 1577 1623 qns_ice(:,:,:) = zqns_ice(:,:,:) 1578 1624 ENDIF 1579 1580 1625 #endif 1581 1626 … … 1628 1673 1629 1674 #if defined key_lim3 1630 CALL wrk_alloc( jpi,jpj, zqsr_oce )1631 1675 ! --- solar flux over ocean --- ! 1632 1676 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax … … 1636 1680 IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) 1637 1681 ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF 1638 1639 CALL wrk_dealloc( jpi,jpj, zqsr_oce )1640 1682 #endif 1641 1683 … … 1688 1730 fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 1689 1731 1690 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 1691 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 1732 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 1733 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 1734 CALL wrk_dealloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1735 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 1692 1736 ! 1693 1737 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_ice_flx') -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90
r5540 r6455 110 110 INTEGER :: jl ! dummy loop index 111 111 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_os, zalb_cs ! ice albedo under overcast/clear sky 112 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalb_ice ! mean ice albedo (for coupled)113 112 REAL(wp), POINTER, DIMENSION(:,: ) :: zutau_ice, zvtau_ice 114 113 !!---------------------------------------------------------------------- … … 197 196 ! fr1_i0 , fr2_i0 : 1sr & 2nd fraction of qsr penetration in ice [%] 198 197 !---------------------------------------------------------------------------------------- 199 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs , zalb_ice)198 CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 200 199 CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 201 200 … … 203 202 CASE( jp_clio ) ! CLIO bulk formulation 204 203 ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo 205 ! ( zalb_ice) is computed within the bulk routine206 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice )207 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi= zalb_ice, psst=sst_m, pist=t_su )208 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx )204 ! (alb_ice) is computed within the bulk routine 205 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 206 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 207 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 209 208 CASE( jp_core ) ! CORE bulk formulation 210 209 ! albedo depends on cloud fraction because of non-linear spectral effects 211 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:)212 CALL blk_ice_core_flx( t_su, zalb_ice )213 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi= zalb_ice, psst=sst_m, pist=t_su )214 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx )210 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 211 CALL blk_ice_core_flx( t_su, alb_ice ) 212 IF( ln_mixcpl ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 213 IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 215 214 CASE ( jp_purecpl ) 216 215 ! albedo depends on cloud fraction because of non-linear spectral effects 217 zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 218 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 219 ! clem: evap_ice is forced to 0 in coupled mode for now 220 ! but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 221 evap_ice (:,:,:) = 0._wp ; devap_ice (:,:,:) = 0._wp 222 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 216 alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 217 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 218 IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 223 219 END SELECT 224 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs , zalb_ice)220 CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 225 221 226 222 !----------------------------! … … 265 261 !!---------------------------------------------------------------------- 266 262 INTEGER :: ierr 263 INTEGER :: ji, jj 267 264 !!---------------------------------------------------------------------- 268 265 IF(lwp) WRITE(numout,*) … … 321 318 tn_ice(:,:,:) = t_su(:,:,:) ! initialisation of surface temp for coupled simu 322 319 ! 320 DO jj = 1, jpj 321 DO ji = 1, jpi 322 IF( gphit(ji,jj) > 0._wp ) THEN ; rn_amax_2d(ji,jj) = rn_amax_n ! NH 323 ELSE ; rn_amax_2d(ji,jj) = rn_amax_s ! SH 324 ENDIF 325 ENDDO 326 ENDDO 327 ! 323 328 nstart = numit + nn_fsbc 324 329 nitrun = nitend - nit000 + 1 … … 343 348 INTEGER :: ios ! Local integer output status for namelist read 344 349 NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir, & 345 & ln_limdyn, rn_amax , ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt350 & ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt 346 351 !!------------------------------------------------------------------- 347 352 ! … … 364 369 WRITE(numout,*) ' number of snow layers = ', nlay_s 365 370 WRITE(numout,*) ' switch for ice dynamics (1) or not (0) ln_limdyn = ', ln_limdyn 366 WRITE(numout,*) ' maximum ice concentration = ', rn_amax 371 WRITE(numout,*) ' maximum ice concentration for NH = ', rn_amax_n 372 WRITE(numout,*) ' maximum ice concentration for SH = ', rn_amax_s 367 373 WRITE(numout,*) ' Diagnose heat/salt budget or not ln_limdiahsb = ', ln_limdiahsb 368 374 WRITE(numout,*) ' Output heat/salt budget or not ln_limdiaout = ', ln_limdiaout … … 579 585 sfx_bog(:,:) = 0._wp ; sfx_dyn(:,:) = 0._wp 580 586 sfx_bom(:,:) = 0._wp ; sfx_sum(:,:) = 0._wp 581 sfx_res(:,:) = 0._wp 587 sfx_res(:,:) = 0._wp ; sfx_sub(:,:) = 0._wp 582 588 583 589 wfx_snw(:,:) = 0._wp ; wfx_ice(:,:) = 0._wp … … 595 601 hfx_spr(:,:) = 0._wp ; hfx_dif(:,:) = 0._wp 596 602 hfx_err(:,:) = 0._wp ; hfx_err_rem(:,:) = 0._wp 597 hfx_err_dif(:,:) = 0._wp ; 598 603 hfx_err_dif(:,:) = 0._wp 604 wfx_err_sub(:,:) = 0._wp 605 599 606 afx_tot(:,:) = 0._wp ; 600 607 afx_dyn(:,:) = 0._wp ; afx_thd(:,:) = 0._wp -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r5628 r6455 456 456 ! ! ---------------------------------------- ! 457 457 IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 458 CALL iom_put( "empmr" , emp - rnf ) ! upward water flux 458 CALL iom_put( "empmr" , emp - rnf ) ! upward water flux 459 CALL iom_put( "empbmr" , emp_b - rnf ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 459 460 CALL iom_put( "saltflx", sfx ) ! downward salt flux 460 461 ! (includes virtual salt flux beneath ice -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90
r5120 r6455 68 68 ! 69 69 rldf = 1 ! For active tracers the 70 r_fact_lap(:,:,:) = 1.0 70 71 71 72 IF( l_trdtra ) THEN !* Save ta and sa trends … … 214 215 IF( ierr == 1 ) CALL ctl_stop( ' iso-level in z-coordinate - partial step, not allowed' ) 215 216 IF( ierr == 2 ) CALL ctl_stop( ' isoneutral bilaplacian operator does not exist' ) 217 IF( ln_traldf_grif .AND. ln_isfcav ) & 218 CALL ctl_stop( ' ice shelf and traldf_grif not tested') 216 219 IF( lk_traldf_eiv .AND. .NOT.ln_traldf_iso ) & 217 220 CALL ctl_stop( ' eddy induced velocity on tracers', & -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r5407 r6455 10 10 !! - ! 2005-11 (G. Madec) zco, zps, sco coordinate 11 11 !! 3.2 ! 2009-04 (G. Madec & NEMO team) 12 !! 4.0 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 12 !! 3.4 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model 13 !! 3.6 ! 2015-12 (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 13 14 !!---------------------------------------------------------------------- 14 15 … … 93 94 !! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 94 95 !! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 96 !! Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 95 97 !!---------------------------------------------------------------------- 96 98 ! … … 101 103 REAL(wp) :: zchl, zcoef, zfact ! local scalars 102 104 REAL(wp) :: zc0, zc1, zc2, zc3 ! - - 103 REAL(wp) :: zzc0, zzc1, zzc2, zzc3 ! - -104 105 REAL(wp) :: zz0, zz1, z1_e3t ! - - 106 REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 107 REAL(wp) :: zlogc, zlogc2, zlogc3 105 108 REAL(wp), POINTER, DIMENSION(:,: ) :: zekb, zekg, zekr 106 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 107 !!---------------------------------------------------------------------- 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt, zchl3d 110 !!-------------------------------------------------------------------------- 108 111 ! 109 112 IF( nn_timing == 1 ) CALL timing_start('tra_qsr') 110 113 ! 111 114 CALL wrk_alloc( jpi, jpj, zekb, zekg, zekr ) 112 CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )115 CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 113 116 ! 114 117 IF( kt == nit000 ) THEN … … 183 186 ! ! ------------------------- ! 184 187 ! Set chlorophyl concentration 185 IF( nn_chldta == 1 .OR. lk_vvl ) THEN !* Variable Chlorophyll or ocean volume 186 ! 187 IF( nn_chldta == 1 ) THEN !* Variable Chlorophyll 188 ! 189 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 190 ! 191 !CDIR COLLAPSE 188 IF( nn_chldta == 1 .OR. nn_chldta == 2 .OR. lk_vvl ) THEN !* Variable Chlorophyll or ocean volume 189 ! 190 IF( nn_chldta == 1 ) THEN !* 2D Variable Chlorophyll 191 ! 192 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 193 DO jk = 1, nksr + 1 194 zchl3d(:,:,jk) = sf_chl(1)%fnow(:,:,1) 195 ENDDO 196 ! 197 ELSE IF( nn_chldta == 2 ) THEN !* -3-D Variable Chlorophyll 198 ! 199 CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step 200 !CDIR NOVERRCHK ! 201 DO jj = 1, jpj 192 202 !CDIR NOVERRCHK 193 DO jj = 1, jpj ! Separation in R-G-B depending of the surface Chl 194 !CDIR NOVERRCHK 195 DO ji = 1, jpi 196 zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 197 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 198 zekb(ji,jj) = rkrgb(1,irgb) 199 zekg(ji,jj) = rkrgb(2,irgb) 200 zekr(ji,jj) = rkrgb(3,irgb) 201 END DO 202 END DO 203 ELSE ! Variable ocean volume but constant chrlorophyll 204 zchl = 0.05 ! constant chlorophyll 205 irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 206 zekb(:,:) = rkrgb(1,irgb) ! Separation in R-G-B depending of the chlorophyll 207 zekg(:,:) = rkrgb(2,irgb) 208 zekr(:,:) = rkrgb(3,irgb) 203 DO ji = 1, jpi 204 zchl = sf_chl(1)%fnow(ji,jj,1) 205 zCtot = 40.6 * zchl**0.459 206 zze = 568.2 * zCtot**(-0.746) 207 IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 208 zlogc = LOG( zchl ) 209 zlogc2 = zlogc * zlogc 210 zlogc3 = zlogc * zlogc * zlogc 211 zCb = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 212 zCmax = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 213 zpsimax = 0.6 - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 214 zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 215 zCze = 1.12 * (zchl)**0.803 216 DO jk = 1, nksr + 1 217 zpsi = fsdept(ji,jj,jk) / zze 218 zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 219 END DO 220 ! 221 END DO 222 END DO 223 ! 224 ELSE !* Variable ocean volume but constant chrlorophyll 225 DO jk = 1, nksr + 1 226 zchl3d(:,:,jk) = 0.05 227 ENDDO 209 228 ENDIF 210 229 ! 211 zcoef = ( 1. - rn_abs ) / 3.e0 ! equi-partition in R-G-B230 zcoef = ( 1. - rn_abs ) / 3.e0 ! equi-partition in R-G-B 212 231 ze0(:,:,1) = rn_abs * qsr(:,:) 213 232 ze1(:,:,1) = zcoef * qsr(:,:) … … 217 236 ! 218 237 DO jk = 2, nksr+1 238 ! 239 DO jj = 1, jpj ! Separation in R-G-B depending of vertical profile of Chl 240 !CDIR NOVERRCHK 241 DO ji = 1, jpi 242 zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 243 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 244 zekb(ji,jj) = rkrgb(1,irgb) 245 zekg(ji,jj) = rkrgb(2,irgb) 246 zekr(ji,jj) = rkrgb(3,irgb) 247 END DO 248 END DO 219 249 !CDIR NOVERRCHK 220 250 DO jj = 1, jpj … … 233 263 END DO 234 264 END DO 235 ! clem: store attenuation coefficient of the first ocean level236 IF ( ln_qsr_ice ) THEN237 DO jj = 1, jpj238 DO ji = 1, jpi239 zzc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r )240 zzc1 = zcoef * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) )241 zzc2 = zcoef * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) )242 zzc3 = zcoef * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) )243 fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2 + zzc3 ) * tmask(ji,jj,2)244 END DO245 END DO246 ENDIF247 265 ! 248 266 DO jk = 1, nksr ! compute and add qsr trend to ta … … 251 269 zea(:,:,nksr+1:jpk) = 0.e0 ! below 400m set to zero 252 270 CALL iom_put( 'qsr3d', zea ) ! Shortwave Radiation 3D distribution 271 ! 272 IF ( ln_qsr_ice ) THEN ! store attenuation coefficient of the first ocean level 273 !CDIR NOVERRCHK 274 DO jj = 1, jpj ! Separation in R-G-B depending of the surface Chl 275 !CDIR NOVERRCHK 276 DO ji = 1, jpi 277 zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,1) ) ) 278 irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 279 zekb(ji,jj) = rkrgb(1,irgb) 280 zekg(ji,jj) = rkrgb(2,irgb) 281 zekr(ji,jj) = rkrgb(3,irgb) 282 END DO 283 END DO 284 ! 285 DO jj = 1, jpj 286 DO ji = 1, jpi 287 zc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r ) 288 zc1 = zcoef * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 289 zc2 = zcoef * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 290 zc3 = zcoef * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 291 fraqsr_1lev(ji,jj) = 1.0 - ( zc0 + zc1 + zc2 + zc3 ) * tmask(ji,jj,2) 292 END DO 293 END DO 294 ! 295 ENDIF 253 296 ! 254 297 ELSE !* Constant Chlorophyll … … 256 299 qsr_hc(:,:,jk) = etot3(:,:,jk) * qsr(:,:) 257 300 END DO 258 ! clem:store attenuation coefficient of the first ocean level259 IF 301 ! store attenuation coefficient of the first ocean level 302 IF( ln_qsr_ice ) THEN 260 303 fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 261 304 ENDIF … … 339 382 ! 340 383 CALL wrk_dealloc( jpi, jpj, zekb, zekg, zekr ) 341 CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )384 CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d ) 342 385 ! 343 386 IF( nn_timing == 1 ) CALL timing_stop('tra_qsr') … … 405 448 WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio 406 449 WRITE(numout,*) ' light penetration for ice-model LIM3 ln_qsr_ice = ', ln_qsr_ice 407 WRITE(numout,*) ' RGB : Chl data (=1 ) or cst value (=0)nn_chldta = ', nn_chldta450 WRITE(numout,*) ' RGB : Chl data (=1/2) or cst value (=0) nn_chldta = ', nn_chldta 408 451 WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs 409 452 WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0 … … 429 472 IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = 1 430 473 IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = 2 431 IF( ln_qsr_2bd ) nqsr = 3 432 IF( ln_qsr_bio ) nqsr = 4 474 IF( ln_qsr_rgb .AND. nn_chldta == 2 ) nqsr = 3 475 IF( ln_qsr_2bd ) nqsr = 4 476 IF( ln_qsr_bio ) nqsr = 5 433 477 ! 434 478 IF(lwp) THEN ! Print the choice 435 479 WRITE(numout,*) 436 480 IF( nqsr == 1 ) WRITE(numout,*) ' R-G-B light penetration - Constant Chlorophyll' 437 IF( nqsr == 2 ) WRITE(numout,*) ' R-G-B light penetration - Chl data ' 438 IF( nqsr == 3 ) WRITE(numout,*) ' 2 bands light penetration' 439 IF( nqsr == 4 ) WRITE(numout,*) ' bio-model light penetration' 481 IF( nqsr == 2 ) WRITE(numout,*) ' R-G-B light penetration - 2D Chl data ' 482 IF( nqsr == 3 ) WRITE(numout,*) ' R-G-B light penetration - 3D Chl data ' 483 IF( nqsr == 4 ) WRITE(numout,*) ' 2 bands light penetration' 484 IF( nqsr == 5 ) WRITE(numout,*) ' bio-model light penetration' 440 485 ENDIF 441 486 ! … … 460 505 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 461 506 ! 462 IF( nn_chldta == 1 ) THEN !* Chl data : set sf_chl structure507 IF( nn_chldta == 1 .OR. nn_chldta == 2 ) THEN !* Chl data : set sf_chl structure 463 508 IF(lwp) WRITE(numout,*) 464 509 IF(lwp) WRITE(numout,*) ' Chlorophyll read in a file' -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90
r5120 r6455 177 177 & + 0.15 * zrau(ji,jj) * zmskd2(ji,jj) ) 178 178 ! add to the eddy viscosity coef. previously computed 179 # if defined key_zdftmx_new 180 ! key_zdftmx_new: New internal wave-driven param: use avs value computed by zdftmx 181 avs (ji,jj,jk) = avs(ji,jj,jk) + zavfs + zavds 182 # else 179 183 avs (ji,jj,jk) = avt(ji,jj,jk) + zavfs + zavds 184 # endif 180 185 avt (ji,jj,jk) = avt(ji,jj,jk) + zavft + zavdt 181 186 avm (ji,jj,jk) = avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90
r6204 r6455 80 80 INTEGER, INTENT(in) :: kt ! ocean time-step index 81 81 ! 82 INTEGER :: ji, jj, jk ! dummy loop indices83 INTEGER :: iikn, iiki, ikt , imkt! local integer84 REAL(wp) :: zN2_c ! local scalar82 INTEGER :: ji, jj, jk ! dummy loop indices 83 INTEGER :: iikn, iiki, ikt ! local integer 84 REAL(wp) :: zN2_c ! local scalar 85 85 INTEGER, POINTER, DIMENSION(:,:) :: imld ! 2D workspace 86 86 !!---------------------------------------------------------------------- … … 117 117 DO jj = 1, jpj 118 118 DO ji = 1, jpi 119 imkt = mikt(ji,jj) 120 IF( avt (ji,jj,jk) < avt_c ) imld(ji,jj) = MAX( imkt, jk ) ! Turbocline 119 IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) ) imld(ji,jj) = jk ! Turbocline 121 120 END DO 122 121 END DO … … 127 126 iiki = imld(ji,jj) 128 127 iikn = nmln(ji,jj) 129 imkt = mikt(ji,jj) 130 hmld (ji,jj) = ( fsdepw(ji,jj,iiki ) - fsdepw(ji,jj,imkt ) ) * ssmask(ji,jj) ! Turbocline depth 131 hmlp (ji,jj) = ( fsdepw(ji,jj,iikn ) - fsdepw(ji,jj,imkt ) ) * ssmask(ji,jj) ! Mixed layer depth 132 hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,imkt ) ) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer 128 hmld (ji,jj) = fsdepw(ji,jj,iiki ) * ssmask(ji,jj) ! Turbocline depth 129 hmlp (ji,jj) = fsdepw(ji,jj,iikn ) * ssmask(ji,jj) ! Mixed layer depth 130 hmlpt(ji,jj) = fsdept(ji,jj,iikn-1) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer 133 131 END DO 134 132 END DO 135 IF( .NOT.lk_offline ) THEN ! no need to output in offline mode 136 CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth 137 CALL iom_put( "mldkz5" , hmld ) ! turbocline depth 133 ! no need to output in offline mode 134 IF( .NOT.lk_offline ) THEN 135 IF ( iom_use("mldr10_1") ) THEN 136 IF( ln_isfcav ) THEN 137 CALL iom_put( "mldr10_1", hmlp - risfdep) ! mixed layer thickness 138 ELSE 139 CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth 140 END IF 141 END IF 142 IF ( iom_use("mldkz5") ) THEN 143 IF( ln_isfcav ) THEN 144 CALL iom_put( "mldkz5" , hmld - risfdep ) ! turbocline thickness 145 ELSE 146 CALL iom_put( "mldkz5" , hmld ) ! turbocline depth 147 END IF 148 END IF 138 149 ENDIF 139 150 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90
r6204 r6455 357 357 DO ji = fs_2, fs_jpim1 ! vector opt. 358 358 zcof = zfact1 * tmask(ji,jj,jk) 359 # if defined key_zdftmx_new 360 ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 361 zzd_up = zcof * ( MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) ) & ! upper diagonal 362 & / ( fse3t(ji,jj,jk ) * fse3w(ji,jj,jk ) ) 363 zzd_lw = zcof * ( MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) ) & ! lower diagonal 364 & / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk ) ) 365 # else 359 366 zzd_up = zcof * ( avm (ji,jj,jk+1) + avm (ji,jj,jk ) ) & ! upper diagonal 360 367 & / ( fse3t(ji,jj,jk ) * fse3w(ji,jj,jk ) ) 361 368 zzd_lw = zcof * ( avm (ji,jj,jk ) + avm (ji,jj,jk-1) ) & ! lower diagonal 362 369 & / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk ) ) 370 # endif 363 371 ! ! shear prod. at w-point weightened by mask 364 372 zesh2 = ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) ) & … … 735 743 ! 736 744 ri_cri = 2._wp / ( 2._wp + rn_ediss / rn_ediff ) ! resulting critical Richardson number 745 # if defined key_zdftmx_new 746 ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 747 rn_emin = 1.e-10_wp 748 rmxl_min = 1.e-03_wp 749 IF(lwp) THEN ! Control print 750 WRITE(numout,*) 751 WRITE(numout,*) 'zdf_tke_init : New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 752 WRITE(numout,*) '~~~~~~~~~~~~' 753 ENDIF 754 # else 737 755 rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) ) ! resulting minimum length to recover molecular viscosity 756 # endif 738 757 ! 739 758 IF(lwp) THEN !* Control print -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90
r5130 r6455 561 561 END SUBROUTINE zdf_tmx_init 562 562 563 #elif defined key_zdftmx_new 564 !!---------------------------------------------------------------------- 565 !! 'key_zdftmx_new' Internal wave-driven vertical mixing 566 !!---------------------------------------------------------------------- 567 !! zdf_tmx : global momentum & tracer Kz with wave induced Kz 568 !! zdf_tmx_init : global momentum & tracer Kz with wave induced Kz 569 !!---------------------------------------------------------------------- 570 USE oce ! ocean dynamics and tracers variables 571 USE dom_oce ! ocean space and time domain variables 572 USE zdf_oce ! ocean vertical physics variables 573 USE zdfddm ! ocean vertical physics: double diffusive mixing 574 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 575 USE eosbn2 ! ocean equation of state 576 USE phycst ! physical constants 577 USE prtctl ! Print control 578 USE in_out_manager ! I/O manager 579 USE iom ! I/O Manager 580 USE lib_mpp ! MPP library 581 USE wrk_nemo ! work arrays 582 USE timing ! Timing 583 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 584 585 IMPLICIT NONE 586 PRIVATE 587 588 PUBLIC zdf_tmx ! called in step module 589 PUBLIC zdf_tmx_init ! called in nemogcm module 590 PUBLIC zdf_tmx_alloc ! called in nemogcm module 591 592 LOGICAL, PUBLIC, PARAMETER :: lk_zdftmx = .TRUE. !: wave-driven mixing flag 593 594 ! !!* Namelist namzdf_tmx : internal wave-driven mixing * 595 INTEGER :: nn_zpyc ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2) 596 LOGICAL :: ln_mevar ! variable (=T) or constant (=F) mixing efficiency 597 LOGICAL :: ln_tsdiff ! account for differential T/S wave-driven mixing (=T) or not (=F) 598 599 REAL(wp) :: r1_6 = 1._wp / 6._wp 600 601 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ebot_tmx ! power available from high-mode wave breaking (W/m2) 602 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: epyc_tmx ! power available from low-mode, pycnocline-intensified wave breaking (W/m2) 603 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ecri_tmx ! power available from low-mode, critical slope wave breaking (W/m2) 604 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbot_tmx ! WKB decay scale for high-mode energy dissipation (m) 605 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hcri_tmx ! decay scale for low-mode critical slope dissipation (m) 606 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: emix_tmx ! local energy density available for mixing (W/kg) 607 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: bflx_tmx ! buoyancy flux Kz * N^2 (W/kg) 608 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: pcmap_tmx ! vertically integrated buoyancy flux (W/m2) 609 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) 610 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: zav_wave ! Internal wave-induced diffusivity 611 612 !! * Substitutions 613 # include "zdfddm_substitute.h90" 614 # include "domzgr_substitute.h90" 615 # include "vectopt_loop_substitute.h90" 616 !!---------------------------------------------------------------------- 617 !! NEMO/OPA 4.0 , NEMO Consortium (2016) 618 !! $Id$ 619 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 620 !!---------------------------------------------------------------------- 621 CONTAINS 622 623 INTEGER FUNCTION zdf_tmx_alloc() 624 !!---------------------------------------------------------------------- 625 !! *** FUNCTION zdf_tmx_alloc *** 626 !!---------------------------------------------------------------------- 627 ALLOCATE( ebot_tmx(jpi,jpj), epyc_tmx(jpi,jpj), ecri_tmx(jpi,jpj) , & 628 & hbot_tmx(jpi,jpj), hcri_tmx(jpi,jpj), emix_tmx(jpi,jpj,jpk), & 629 & bflx_tmx(jpi,jpj,jpk), pcmap_tmx(jpi,jpj), zav_ratio(jpi,jpj,jpk), & 630 & zav_wave(jpi,jpj,jpk), STAT=zdf_tmx_alloc ) 631 ! 632 IF( lk_mpp ) CALL mpp_sum ( zdf_tmx_alloc ) 633 IF( zdf_tmx_alloc /= 0 ) CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays') 634 END FUNCTION zdf_tmx_alloc 635 636 637 SUBROUTINE zdf_tmx( kt ) 638 !!---------------------------------------------------------------------- 639 !! *** ROUTINE zdf_tmx *** 640 !! 641 !! ** Purpose : add to the vertical mixing coefficients the effect of 642 !! breaking internal waves. 643 !! 644 !! ** Method : - internal wave-driven vertical mixing is given by: 645 !! Kz_wave = min( 100 cm2/s, f( Reb = emix_tmx /( Nu * N^2 ) ) 646 !! where emix_tmx is the 3D space distribution of the wave-breaking 647 !! energy and Nu the molecular kinematic viscosity. 648 !! The function f(Reb) is linear (constant mixing efficiency) 649 !! if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. 650 !! 651 !! - Compute emix_tmx, the 3D power density that allows to compute 652 !! Reb and therefrom the wave-induced vertical diffusivity. 653 !! This is divided into three components: 654 !! 1. Bottom-intensified low-mode dissipation at critical slopes 655 !! emix_tmx(z) = ( ecri_tmx / rau0 ) * EXP( -(H-z)/hcri_tmx ) 656 !! / ( 1. - EXP( - H/hcri_tmx ) ) * hcri_tmx 657 !! where hcri_tmx is the characteristic length scale of the bottom 658 !! intensification, ecri_tmx a map of available power, and H the ocean depth. 659 !! 2. Pycnocline-intensified low-mode dissipation 660 !! emix_tmx(z) = ( epyc_tmx / rau0 ) * ( sqrt(rn2(z))^nn_zpyc ) 661 !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) 662 !! where epyc_tmx is a map of available power, and nn_zpyc 663 !! is the chosen stratification-dependence of the internal wave 664 !! energy dissipation. 665 !! 3. WKB-height dependent high mode dissipation 666 !! emix_tmx(z) = ( ebot_tmx / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_tmx) 667 !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_tmx) * e3w(z) ) 668 !! where hbot_tmx is the characteristic length scale of the WKB bottom 669 !! intensification, ebot_tmx is a map of available power, and z_wkb is the 670 !! WKB-stretched height above bottom defined as 671 !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) 672 !! / SUM( sqrt(rn2(z')) * e3w(z') ) 673 !! 674 !! - update the model vertical eddy viscosity and diffusivity: 675 !! avt = avt + av_wave 676 !! avm = avm + av_wave 677 !! avmu = avmu + mi(av_wave) 678 !! avmv = avmv + mj(av_wave) 679 !! 680 !! - if namelist parameter ln_tsdiff = T, account for differential mixing: 681 !! avs = avt + av_wave * diffusivity_ratio(Reb) 682 !! 683 !! ** Action : - Define emix_tmx used to compute internal wave-induced mixing 684 !! - avt, avs, avm, avmu, avmv increased by internal wave-driven mixing 685 !! 686 !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 687 !!---------------------------------------------------------------------- 688 INTEGER, INTENT(in) :: kt ! ocean time-step 689 ! 690 INTEGER :: ji, jj, jk ! dummy loop indices 691 REAL(wp) :: ztpc ! scalar workspace 692 REAL(wp), DIMENSION(:,:) , POINTER :: zfact ! Used for vertical structure 693 REAL(wp), DIMENSION(:,:) , POINTER :: zhdep ! Ocean depth 694 REAL(wp), DIMENSION(:,:,:), POINTER :: zwkb ! WKB-stretched height above bottom 695 REAL(wp), DIMENSION(:,:,:), POINTER :: zweight ! Weight for high mode vertical distribution 696 REAL(wp), DIMENSION(:,:,:), POINTER :: znu_t ! Molecular kinematic viscosity (T grid) 697 REAL(wp), DIMENSION(:,:,:), POINTER :: znu_w ! Molecular kinematic viscosity (W grid) 698 REAL(wp), DIMENSION(:,:,:), POINTER :: zReb ! Turbulence intensity parameter 699 !!---------------------------------------------------------------------- 700 ! 701 IF( nn_timing == 1 ) CALL timing_start('zdf_tmx') 702 ! 703 CALL wrk_alloc( jpi,jpj, zfact, zhdep ) 704 CALL wrk_alloc( jpi,jpj,jpk, zwkb, zweight, znu_t, znu_w, zReb ) 705 706 ! ! ----------------------------- ! 707 ! ! Internal wave-driven mixing ! (compute zav_wave) 708 ! ! ----------------------------- ! 709 ! 710 ! !* Critical slope mixing: distribute energy over the time-varying ocean depth, 711 ! using an exponential decay from the seafloor. 712 DO jj = 1, jpj ! part independent of the level 713 DO ji = 1, jpi 714 zhdep(ji,jj) = fsdepw(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean 715 zfact(ji,jj) = rau0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_tmx(ji,jj) ) ) 716 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ecri_tmx(ji,jj) / zfact(ji,jj) 717 END DO 718 END DO 719 720 DO jk = 2, jpkm1 ! complete with the level-dependent part 721 emix_tmx(:,:,jk) = zfact(:,:) * ( EXP( ( fsde3w(:,:,jk ) - zhdep(:,:) ) / hcri_tmx(:,:) ) & 722 & - EXP( ( fsde3w(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) ) ) * wmask(:,:,jk) & 723 & / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 724 END DO 725 726 ! !* Pycnocline-intensified mixing: distribute energy over the time-varying 727 ! !* ocean depth as proportional to sqrt(rn2)^nn_zpyc 728 729 SELECT CASE ( nn_zpyc ) 730 731 CASE ( 1 ) ! Dissipation scales as N (recommended) 732 733 zfact(:,:) = 0._wp 734 DO jk = 2, jpkm1 ! part independent of the level 735 zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 736 END DO 737 738 DO jj = 1, jpj 739 DO ji = 1, jpi 740 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 741 END DO 742 END DO 743 744 DO jk = 2, jpkm1 ! complete with the level-dependent part 745 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 746 END DO 747 748 CASE ( 2 ) ! Dissipation scales as N^2 749 750 zfact(:,:) = 0._wp 751 DO jk = 2, jpkm1 ! part independent of the level 752 zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 753 END DO 754 755 DO jj= 1, jpj 756 DO ji = 1, jpi 757 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 758 END DO 759 END DO 760 761 DO jk = 2, jpkm1 ! complete with the level-dependent part 762 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 763 END DO 764 765 END SELECT 766 767 ! !* WKB-height dependent mixing: distribute energy over the time-varying 768 ! !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) 769 770 zwkb(:,:,:) = 0._wp 771 zfact(:,:) = 0._wp 772 DO jk = 2, jpkm1 773 zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) 774 zwkb(:,:,jk) = zfact(:,:) 775 END DO 776 777 DO jk = 2, jpkm1 778 DO jj = 1, jpj 779 DO ji = 1, jpi 780 IF( zfact(ji,jj) /= 0 ) zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) ) & 781 & * tmask(ji,jj,jk) / zfact(ji,jj) 782 END DO 783 END DO 784 END DO 785 zwkb(:,:,1) = zhdep(:,:) * tmask(:,:,1) 786 787 zweight(:,:,:) = 0._wp 788 DO jk = 2, jpkm1 789 zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_tmx(:,:) * wmask(:,:,jk) & 790 & * ( EXP( -zwkb(:,:,jk) / hbot_tmx(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_tmx(:,:) ) ) 791 END DO 792 793 zfact(:,:) = 0._wp 794 DO jk = 2, jpkm1 ! part independent of the level 795 zfact(:,:) = zfact(:,:) + zweight(:,:,jk) 796 END DO 797 798 DO jj = 1, jpj 799 DO ji = 1, jpi 800 IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ebot_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 801 END DO 802 END DO 803 804 DO jk = 2, jpkm1 ! complete with the level-dependent part 805 emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk) & 806 & / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 807 END DO 808 809 810 ! Calculate molecular kinematic viscosity 811 znu_t(:,:,:) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem) & 812 & + 0.02305_wp * tsn(:,:,:,jp_sal) ) * tmask(:,:,:) * r1_rau0 813 DO jk = 2, jpkm1 814 znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) 815 END DO 816 817 ! Calculate turbulence intensity parameter Reb 818 DO jk = 2, jpkm1 819 zReb(:,:,jk) = emix_tmx(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) ) 820 END DO 821 822 ! Define internal wave-induced diffusivity 823 DO jk = 2, jpkm1 824 zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6 ! This corresponds to a constant mixing efficiency of 1/6 825 END DO 826 827 IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the 828 DO jk = 2, jpkm1 ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 829 DO jj = 1, jpj 830 DO ji = 1, jpi 831 IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 832 zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 833 ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN 834 zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 835 ENDIF 836 END DO 837 END DO 838 END DO 839 ENDIF 840 841 DO jk = 2, jpkm1 ! Bound diffusivity by molecular value and 100 cm2/s 842 zav_wave(:,:,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp ) * wmask(:,:,jk) 843 END DO 844 845 IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave 846 ztpc = 0._wp 847 DO jk = 2, jpkm1 848 DO jj = 1, jpj 849 DO ji = 1, jpi 850 ztpc = ztpc + fse3w(ji,jj,jk) * e1e2t(ji,jj) & 851 & * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 852 END DO 853 END DO 854 END DO 855 IF( lk_mpp ) CALL mpp_sum( ztpc ) 856 ztpc = rau0 * ztpc ! Global integral of rauo * Kz * N^2 = power contributing to mixing 857 858 IF(lwp) THEN 859 WRITE(numout,*) 860 WRITE(numout,*) 'zdf_tmx : Internal wave-driven mixing (tmx)' 861 WRITE(numout,*) '~~~~~~~ ' 862 WRITE(numout,*) 863 WRITE(numout,*) ' Total power consumption by av_wave: ztpc = ', ztpc * 1.e-12_wp, 'TW' 864 ENDIF 865 ENDIF 866 867 ! ! ----------------------- ! 868 ! ! Update mixing coefs ! 869 ! ! ----------------------- ! 870 ! 871 IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature 872 DO jk = 2, jpkm1 ! Calculate S/T diffusivity ratio as a function of Reb 873 DO jj = 1, jpj 874 DO ji = 1, jpi 875 zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp * & 876 & TANH( 0.92_wp * ( LOG10( MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 ) ) - 0.60_wp ) ) & 877 & ) * wmask(ji,jj,jk) 878 END DO 879 END DO 880 END DO 881 CALL iom_put( "av_ratio", zav_ratio ) 882 DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with wave-driven mixing 883 fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk) 884 avt (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 885 avm (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 886 END DO 887 ! 888 ELSE !* update momentum & tracer diffusivity with wave-driven mixing 889 DO jk = 2, jpkm1 890 fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 891 avt (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 892 avm (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 893 END DO 894 ENDIF 895 896 DO jk = 2, jpkm1 !* update momentum diffusivity at wu and wv points 897 DO jj = 2, jpjm1 898 DO ji = fs_2, fs_jpim1 ! vector opt. 899 avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji+1,jj ,jk) ) * wumask(ji,jj,jk) 900 avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji ,jj+1,jk) ) * wvmask(ji,jj,jk) 901 END DO 902 END DO 903 END DO 904 CALL lbc_lnk( avmu, 'U', 1. ) ; CALL lbc_lnk( avmv, 'V', 1. ) ! lateral boundary condition 905 906 ! !* output internal wave-driven mixing coefficient 907 CALL iom_put( "av_wave", zav_wave ) 908 !* output useful diagnostics: N^2, Kz * N^2 (bflx_tmx), 909 ! vertical integral of rau0 * Kz * N^2 (pcmap_tmx), energy density (emix_tmx) 910 IF( iom_use("bflx_tmx") .OR. iom_use("pcmap_tmx") ) THEN 911 bflx_tmx(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) 912 pcmap_tmx(:,:) = 0._wp 913 DO jk = 2, jpkm1 914 pcmap_tmx(:,:) = pcmap_tmx(:,:) + fse3w(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 915 END DO 916 pcmap_tmx(:,:) = rau0 * pcmap_tmx(:,:) 917 CALL iom_put( "bflx_tmx", bflx_tmx ) 918 CALL iom_put( "pcmap_tmx", pcmap_tmx ) 919 ENDIF 920 CALL iom_put( "bn2", rn2 ) 921 CALL iom_put( "emix_tmx", emix_tmx ) 922 923 CALL wrk_dealloc( jpi,jpj, zfact, zhdep ) 924 CALL wrk_dealloc( jpi,jpj,jpk, zwkb, zweight, znu_t, znu_w, zReb ) 925 926 IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' tmx - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 927 ! 928 IF( nn_timing == 1 ) CALL timing_stop('zdf_tmx') 929 ! 930 END SUBROUTINE zdf_tmx 931 932 933 SUBROUTINE zdf_tmx_init 934 !!---------------------------------------------------------------------- 935 !! *** ROUTINE zdf_tmx_init *** 936 !! 937 !! ** Purpose : Initialization of the wave-driven vertical mixing, reading 938 !! of input power maps and decay length scales in netcdf files. 939 !! 940 !! ** Method : - Read the namzdf_tmx namelist and check the parameters 941 !! 942 !! - Read the input data in NetCDF files : 943 !! power available from high-mode wave breaking (mixing_power_bot.nc) 944 !! power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) 945 !! power available from critical slope wave-breaking (mixing_power_cri.nc) 946 !! WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) 947 !! decay scale for critical slope wave-breaking (decay_scale_cri.nc) 948 !! 949 !! ** input : - Namlist namzdf_tmx 950 !! - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, 951 !! decay_scale_bot.nc decay_scale_cri.nc 952 !! 953 !! ** Action : - Increase by 1 the nstop flag is setting problem encounter 954 !! - Define ebot_tmx, epyc_tmx, ecri_tmx, hbot_tmx, hcri_tmx 955 !! 956 !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 957 !! 958 !!---------------------------------------------------------------------- 959 INTEGER :: ji, jj, jk ! dummy loop indices 960 INTEGER :: inum ! local integer 961 INTEGER :: ios 962 REAL(wp) :: zbot, zpyc, zcri ! local scalars 963 !! 964 NAMELIST/namzdf_tmx_new/ nn_zpyc, ln_mevar, ln_tsdiff 965 !!---------------------------------------------------------------------- 966 ! 967 IF( nn_timing == 1 ) CALL timing_start('zdf_tmx_init') 968 ! 969 REWIND( numnam_ref ) ! Namelist namzdf_tmx in reference namelist : Wave-driven mixing 970 READ ( numnam_ref, namzdf_tmx_new, IOSTAT = ios, ERR = 901) 971 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist', lwp ) 972 ! 973 REWIND( numnam_cfg ) ! Namelist namzdf_tmx in configuration namelist : Wave-driven mixing 974 READ ( numnam_cfg, namzdf_tmx_new, IOSTAT = ios, ERR = 902 ) 975 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist', lwp ) 976 IF(lwm) WRITE ( numond, namzdf_tmx_new ) 977 ! 978 IF(lwp) THEN ! Control print 979 WRITE(numout,*) 980 WRITE(numout,*) 'zdf_tmx_init : internal wave-driven mixing' 981 WRITE(numout,*) '~~~~~~~~~~~~' 982 WRITE(numout,*) ' Namelist namzdf_tmx_new : set wave-driven mixing parameters' 983 WRITE(numout,*) ' Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc 984 WRITE(numout,*) ' Variable (T) or constant (F) mixing efficiency = ', ln_mevar 985 WRITE(numout,*) ' Differential internal wave-driven mixing (T) or not (F) = ', ln_tsdiff 986 ENDIF 987 988 ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and 989 ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should 990 ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). 991 avmb(:) = 1.4e-6_wp ! viscous molecular value 992 avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_tmx) 993 avtb_2d(:,:) = 1.e0_wp ! uniform 994 IF(lwp) THEN ! Control print 995 WRITE(numout,*) 996 WRITE(numout,*) ' Force the background value applied to avm & avt in TKE to be everywhere ', & 997 & 'the viscous molecular value & a very small diffusive value, resp.' 998 ENDIF 999 1000 IF( .NOT.lk_zdfddm ) CALL ctl_stop( 'STOP', 'zdf_tmx_init_new : key_zdftmx_new requires key_zdfddm' ) 1001 1002 ! ! allocate tmx arrays 1003 IF( zdf_tmx_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) 1004 ! 1005 ! ! read necessary fields 1006 CALL iom_open('mixing_power_bot',inum) ! energy flux for high-mode wave breaking [W/m2] 1007 CALL iom_get (inum, jpdom_data, 'field', ebot_tmx, 1 ) 1008 CALL iom_close(inum) 1009 ! 1010 CALL iom_open('mixing_power_pyc',inum) ! energy flux for pynocline-intensified wave breaking [W/m2] 1011 CALL iom_get (inum, jpdom_data, 'field', epyc_tmx, 1 ) 1012 CALL iom_close(inum) 1013 ! 1014 CALL iom_open('mixing_power_cri',inum) ! energy flux for critical slope wave breaking [W/m2] 1015 CALL iom_get (inum, jpdom_data, 'field', ecri_tmx, 1 ) 1016 CALL iom_close(inum) 1017 ! 1018 CALL iom_open('decay_scale_bot',inum) ! spatially variable decay scale for high-mode wave breaking [m] 1019 CALL iom_get (inum, jpdom_data, 'field', hbot_tmx, 1 ) 1020 CALL iom_close(inum) 1021 ! 1022 CALL iom_open('decay_scale_cri',inum) ! spatially variable decay scale for critical slope wave breaking [m] 1023 CALL iom_get (inum, jpdom_data, 'field', hcri_tmx, 1 ) 1024 CALL iom_close(inum) 1025 1026 ebot_tmx(:,:) = ebot_tmx(:,:) * ssmask(:,:) 1027 epyc_tmx(:,:) = epyc_tmx(:,:) * ssmask(:,:) 1028 ecri_tmx(:,:) = ecri_tmx(:,:) * ssmask(:,:) 1029 1030 ! Set once for all to zero the first and last vertical levels of appropriate variables 1031 emix_tmx (:,:, 1 ) = 0._wp 1032 emix_tmx (:,:,jpk) = 0._wp 1033 zav_ratio(:,:, 1 ) = 0._wp 1034 zav_ratio(:,:,jpk) = 0._wp 1035 zav_wave (:,:, 1 ) = 0._wp 1036 zav_wave (:,:,jpk) = 0._wp 1037 1038 zbot = glob_sum( e1e2t(:,:) * ebot_tmx(:,:) ) 1039 zpyc = glob_sum( e1e2t(:,:) * epyc_tmx(:,:) ) 1040 zcri = glob_sum( e1e2t(:,:) * ecri_tmx(:,:) ) 1041 IF(lwp) THEN 1042 WRITE(numout,*) ' High-mode wave-breaking energy: ', zbot * 1.e-12_wp, 'TW' 1043 WRITE(numout,*) ' Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' 1044 WRITE(numout,*) ' Critical slope wave-breaking energy: ', zcri * 1.e-12_wp, 'TW' 1045 ENDIF 1046 ! 1047 IF( nn_timing == 1 ) CALL timing_stop('zdf_tmx_init') 1048 ! 1049 END SUBROUTINE zdf_tmx_init 1050 563 1051 #else 564 1052 !!---------------------------------------------------------------------- -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/OPA_SRC/step.F90
r6204 r6455 338 338 ! 339 339 IF( lrst_oce ) CALL rst_write( kstp ) ! write output ocean restart file 340 IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters 340 341 341 342 #if defined key_agrif -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90
r6453 r6455 121 121 REAL(wp) :: devk510 = 0.0 122 122 ! 123 124 125 123 ! General parameters 126 124 REAL(wp), PARAMETER :: pp_rdel_ah_target = 1.E-4_wp … … 133 131 ! - SOLVE_AT_GENERAL 134 132 INTEGER :: niter_atgen = jp_maxniter_atgen 135 136 137 133 138 134 !!* Substitution … … 182 178 zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel & 183 179 & + 0.0047036e-4*ztkel**2) 184 ! ! SET SOLUBILITIES OF O2 AND CO2185 180 chemc(ji,jj,1) = EXP( zcek1 ) * 1E-6 ! mol/(kg atm) 186 181 chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 … … 261 256 & + LOG(1.0 - 0.001005 * zsal)) 262 257 263 264 258 ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 265 259 zckf = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt & … … 267 261 & + LOG(1.0d0 + zst/zcks)) 268 262 269 270 ! DISSOCIATION CONSTANT FOR BORATE 263 ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 271 264 zckb= (-8966.90 - 2890.53*zsqrt - 77.942*zsal & 272 265 & + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr & 273 266 & + (148.0248 + 137.1942*zsqrt + 1.62142*zsal) & 274 & + (-24.4344 - 25.085*zsqrt - 0.2474*zsal) & 267 & + (-24.4344 - 25.085*zsqrt - 0.2474*zsal) & 275 268 & * zlogt + 0.053105*zsqrt*ztkel 276 269 … … 281 274 zck2 = -1.0*(471.78*ztr + 25.9290 - 3.16967*zlogt & 282 275 - 0.01781*zsal + 0.0001122*zsal*zsal) 283 284 276 285 277 ! PKW (H2O) (MILLERO, 1995) from composite data -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90
r6453 r6455 178 178 zfco2 = satmco2(ji,jj) * ( patm(ji,jj) - zvapsw ) * zfugcoeff 179 179 ! Compute CO2 flux for the sea and air 180 zfld = zfco2* tmask(ji,jj,1) * chemc(ji,jj,1) * zkgco2(ji,jj) ! (mol/L) * (m/s)180 zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj,1) * zkgco2(ji,jj) ! (mol/L) * (m/s) 181 181 zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj) ! (mol/L) (m/s) ? 182 182 oce_co2(ji,jj) = ( zfld - zflu ) * rfact2 * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. … … 216 216 ENDIF 217 217 IF( iom_use( "Dpco2" ) ) THEN 218 zw2d(:,:) = oce_co2(:,:) / e1e2t(:,:) / 1000. * rfact2r * tmask(:,:,1) / ( zkgco2(:,:) * chemc(:,:,1) + rtrn)218 zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 219 219 CALL iom_put( "Dpco2" , zw2d ) 220 220 ENDIF … … 233 233 trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1) 234 234 trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 235 ENDIF236 ENDIF237 238 IF( ln_diatrc ) THEN239 IF( lk_iomput .AND. knt == nrdttrc ) THEN240 CALL iom_put( "Cflx" , oce_co2(:,:) / e1e2t(:,:) / rfact )241 CALL iom_put( "Oflx" , zoflx(:,:) * 1000 * tmask(:,:,1) )242 CALL iom_put( "Kg" , zkgco2(:,:) * tmask(:,:,1) )243 CALL iom_put( "Dpco2", ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) )244 CALL iom_put( "Dpo2" , ( atcox * patm(:,:) - trb(:,:,1,jpoxy) * atcox / ( chemo2(:,:,1) + rtrn ) ) * tmask(:,:,1) )245 ELSE246 trc2d(:,:,jp_pcs0_2d ) = oce_co2(:,:) / e1e2t(:,:) / rfact247 trc2d(:,:,jp_pcs0_2d + 1) = zoflx(:,:) * 1000 * tmask(:,:,1)248 trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1)249 trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1)250 235 ENDIF 251 236 ENDIF -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90
r6453 r6455 72 72 CHARACTER (len=25) :: charout 73 73 REAL(wp), POINTER, DIMENSION(:,: ) :: zpdep, zsidep, zwork1, zwork2, zwork3 74 REAL(wp), POINTER, DIMENSION(:,:) :: zsedcal, zsedsi, zsedc 74 75 REAL(wp), POINTER, DIMENSION(:,: ) :: zdenit2d, zironice, zbureff 75 76 REAL(wp), POINTER, DIMENSION(:,: ) :: zwsbio3, zwsbio4, zwscal … … 87 88 ! Allocate temporary workspace 88 89 CALL wrk_alloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 90 CALL wrk_alloc( jpi, jpj, zsedcal, zsedsi, zsedc ) 89 91 CALL wrk_alloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 90 92 CALL wrk_alloc( jpi, jpj, jpk, zsoufer ) … … 98 100 zwork2 (:,:) = 0.e0 99 101 zwork3 (:,:) = 0.e0 102 zsedsi (:,:) = 0.e0 103 zsedcal (:,:) = 0.e0 104 zsedc (:,:) = 0.e0 100 105 101 106 ! Iron input/uptake due to sea ice : Crude parameterization based on Lancelot et al. … … 315 320 tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 316 321 tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zcaloss * zrivalk 322 zsedcal(ji,jj) = (1.0 - zrivalk) * zcaloss / zdep 323 zsedsi (ji,jj) = (1.0 - zrivsil) * zsiloss / zdep 317 324 #endif 318 325 END DO … … 362 369 tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * (zpdenit + zdenitt) ) 363 370 tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zpdenit + zolimit + zdenitt 364 sdenit(ji,jj) = rdenit * zpdenit * fse3t(ji,jj,ikt) 371 sdenit(ji,jj) = rdenit * zpdenit / zdep 372 zsedc(ji,jj) = (1. - zrivno3) * zwstpoc / zdep 365 373 #endif 366 374 END DO … … 418 426 CALL iom_put( "INTNFIX" , zwork1 ) 419 427 ENDIF 428 IF( iom_use("SedCal" ) ) CALL iom_put( "SedCal", zsedcal(:,:) * 1.e+3 ) 429 IF( iom_use("SedSi" ) ) CALL iom_put( "SedSi", zsedsi (:,:) * 1.e+3 ) 430 IF( iom_use("SedC" ) ) CALL iom_put( "SedC", zsedc (:,:) * 1.e+3 ) 431 IF( iom_use("Sdenit" ) ) CALL iom_put( "Sdenit", sdenit (:,:) * 1.e+3 * rno3 ) 420 432 ENDIF 421 433 ELSE … … 431 443 ! 432 444 CALL wrk_dealloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 445 CALL wrk_dealloc( jpi, jpj, zsedcal , zsedsi, zsedc ) 433 446 CALL wrk_dealloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 434 447 CALL wrk_dealloc( jpi, jpj, jpk, zsoufer ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90
r6453 r6455 100 100 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hi !: ??? 101 101 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: excess !: ??? 102 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aphscale !: 103 102 104 103 105 !!* Temperature dependancy of SMS terms … … 168 170 ALLOCATE( ak13 (jpi,jpj,jpk) , & 169 171 & ak23(jpi,jpj,jpk) , aksp (jpi,jpj,jpk) , & 170 & hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , STAT=ierr(4) ) 172 & hi (jpi,jpj,jpk) , excess(jpi,jpj,jpk) , & 173 & aphscale(jpi,jpj,jpk), STAT=ierr(4) ) 171 174 ! 172 175 !* Temperature dependancy of SMS terms -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90
r6453 r6455 277 277 po4r = 1._wp / 122._wp 278 278 o2nit = 32._wp / 122._wp 279 rdenit = 105._wp / 16._wp 279 o2ut = 133._wp / 122._wp 280 rdenit = ( ( o2ut + o2nit ) * 0.80 - rno3 - rno3 * 0.60 ) / rno3 280 281 rdenita = 3._wp / 5._wp 281 o2ut = 133._wp / 122._wp 282 282 283 283 284 ! Initialization of tracer concentration in case of no restart -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90
r5506 r6455 107 107 108 108 jl = n_trc_index(jn) 109 CALL trc_dta( kt, sf_trcdta(jl) ,rf_trfac(jl)) ! read tracer data at nit000110 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 109 CALL trc_dta( kt, sf_trcdta(jl) ) ! read tracer data at nit000 110 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 111 111 112 112 SELECT CASE ( nn_zdmp_tr ) … … 187 187 INTEGER :: ji , jj, jk, jn, jl, jc ! dummy loop indicesa 188 188 INTEGER :: isrow ! local index 189 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace190 189 191 190 !!---------------------------------------------------------------------- … … 278 277 IF(lwp) WRITE(numout,*) 279 278 ! 280 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation281 !282 279 DO jn = 1, jptra 283 280 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 284 281 jl = n_trc_index(jn) 285 CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) ) ! read tracer data at nit000 286 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 282 CALL trc_dta( kt, sf_trcdta(jl) ) ! read tracer data at nit000 287 283 DO jc = 1, npncts 288 284 DO jk = 1, jpkm1 289 285 DO jj = nctsj1(jc), nctsj2(jc) 290 286 DO ji = nctsi1(jc), nctsi2(jc) 291 trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) * tmask(ji,jj,jk)287 trn(ji,jj,jk,jn) = sf_trcdta(jl)%fnow(ji,jj,jk) * tmask(ji,jj,jk) * rf_trfac(jl) 292 288 trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 293 289 ENDDO … … 297 293 ENDIF 298 294 ENDDO 299 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta )295 ! 300 296 ENDIF 301 297 ! -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90
r5385 r6455 56 56 INTEGER, INTENT( in ) :: kt ! ocean time-step index 57 57 !! 58 INTEGER :: jn 58 INTEGER :: ji, jj, jk, jn 59 REAL(wp) :: zdep 59 60 CHARACTER (len=22) :: charout 60 61 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrtrd … … 66 67 67 68 rldf = rldf_rat 68 69 ! 70 r_fact_lap(:,:,:) = 1. 71 DO jk= 1, jpk 72 DO jj = 1, jpj 73 DO ji = 1, jpi 74 IF( fsdept(ji,jj,jk) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN 75 zdep = MAX( fsdept(ji,jj,jk) - 1000., 0. ) / 1000. 76 r_fact_lap(ji,jj,jk) = MAX( 1., rn_fact_lap * EXP( -zdep ) ) 77 ENDIF 78 END DO 79 END DO 80 END DO 81 ! 69 82 IF( l_trdtrc ) THEN 70 83 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrtrd ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90
r5385 r6455 40 40 REAL(wp), PUBLIC :: rn_ahtrc_0 !: diffusivity coefficient for passive tracer (m2/s) 41 41 REAL(wp), PUBLIC :: rn_ahtrb_0 !: background diffusivity coefficient for passive tracer (m2/s) 42 REAL(wp), PUBLIC :: rn_fact_lap !: Enhanced zonal diffusivity coefficent in the equatorial domain 42 43 43 44 ! !!: ** Treatment of Negative concentrations ( nam_trcrad ) … … 74 75 NAMELIST/namtrc_ldf/ ln_trcldf_lap , & 75 76 & ln_trcldf_bilap, ln_trcldf_level, & 76 & ln_trcldf_hor , ln_trcldf_iso , rn_ahtrc_0, rn_ahtrb_0 77 & ln_trcldf_hor , ln_trcldf_iso , rn_ahtrc_0, rn_ahtrb_0, & 78 & rn_fact_lap 79 77 80 NAMELIST/namtrc_zdf/ ln_trczdf_exp , nn_trczdf_exp 78 81 NAMELIST/namtrc_rad/ ln_trcrad … … 127 130 WRITE(numout,*) ' diffusivity coefficient rn_ahtrc_0 = ', rn_ahtrc_0 128 131 WRITE(numout,*) ' background hor. diffusivity rn_ahtrb_0 = ', rn_ahtrb_0 132 WRITE(numout,*) ' enhanced zonal diffusivity rn_fact_lap = ', rn_fact_lap 129 133 ENDIF 130 134 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
r5385 r6455 170 170 END DO 171 171 ENDIF 172 ! 173 CALL lbc_lnk( sbc_trc(:,:,jn), 'T', 1. ) 172 174 ! Concentration dilution effect on tracers due to evaporation & precipitation 173 175 DO jj = 2, jpj -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90
r5120 r6455 67 67 IF( lk_trabbl ) CALL trc_bbl( kstp ) ! advective (and/or diffusive) bottom boundary layer scheme 68 68 IF( ln_trcdmp ) CALL trc_dmp( kstp ) ! internal damping trends 69 IF( ln_trcdmp_clo ) CALL trc_dmp_clo( kstp ) ! internal damping trends on closed seas only70 69 CALL trc_adv( kstp ) ! horizontal & vertical advection 71 70 CALL trc_ldf( kstp ) ! lateral mixing … … 78 77 CALL trc_nxt( kstp ) ! tracer fields at next time step 79 78 IF( ln_trcrad ) CALL trc_rad( kstp ) ! Correct artificial negative concentrations 79 IF( ln_trcdmp_clo ) CALL trc_dmp_clo( kstp ) ! internal damping trends on closed seas only 80 80 81 81 #if defined key_agrif -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r5385 r6455 116 116 USE ldftra_oce , ONLY : aeiw => aeiw !: eddy induced velocity coef. at w-points (m2/s) 117 117 USE ldftra_oce , ONLY : lk_traldf_eiv => lk_traldf_eiv !: eddy induced velocity flag 118 USE ldftra_oce , ONLY : r_fact_lap => r_fact_lap !: enhanced zonal diffusivity coefficient 118 119 119 120 !* vertical diffusion * -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/trcdta.F90
r5385 r6455 151 151 152 152 153 SUBROUTINE trc_dta( kt, sf_dta , zrf_trfac)153 SUBROUTINE trc_dta( kt, sf_dta ) 154 154 !!---------------------------------------------------------------------- 155 155 !! *** ROUTINE trc_dta *** … … 165 165 INTEGER , INTENT(in ) :: kt ! ocean time-step 166 166 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_dta ! array of information on the field to read 167 REAL(wp) , INTENT(in ) :: zrf_trfac ! multiplication factor168 167 ! 169 168 INTEGER :: ji, jj, jk, jl, jkk, ik ! dummy loop indices … … 234 233 ENDIF 235 234 ! 236 sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * zrf_trfac ! multiplicative factor237 !238 235 IF( lwp .AND. kt == nit000 ) THEN 239 236 clndta = TRIM( sf_dta(1)%clvar ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r5407 r6455 61 61 INTEGER :: jk, jn, jl ! dummy loop indices 62 62 CHARACTER (len=25) :: charout 63 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 4D workspace64 63 !!--------------------------------------------------------------------- 65 64 ! … … 121 120 IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN ! Initialisation of tracer from a file that may also be used for damping 122 121 ! 123 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation124 !125 122 DO jn = 1, jptra 126 123 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 127 124 jl = n_trc_index(jn) 128 CALL trc_dta( nit000, sf_trcdta(jl) ,rf_trfac(jl)) ! read tracer data at nit000129 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:)130 trn(:,:,:,jn) = ztrcdta(:,:,:) * tmask(:,:,:)125 CALL trc_dta( nit000, sf_trcdta(jl) ) ! read tracer data at nit000 126 trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 127 ! 131 128 IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN !== deallocate data structure ==! 132 129 ! (data used only for initialisation) … … 138 135 ENDIF 139 136 ENDDO 140 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta )137 ! 141 138 ENDIF 142 139 ! -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/DMP_TOOLS/src/zoom.F90
r4739 r6455 29 29 NAMELIST/nam_zoom_dmp/lzoom_n,lzoom_e,lzoom_w,lzoom_s 30 30 !!---------------------------------------------------------------------- 31 !32 IF( nn_timing == 1 ) CALL timing_start( 'dtacof_zoom')33 !34 31 35 32 ! Read namelist -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/MISCELLANEOUS/icb_pp.py
r4990 r6455 55 55 if procnum < 1: 56 56 print('Need some files to collate! procnum = ',procnum) 57 sys.exit( )57 sys.exit(11) 58 58 59 59 icu = [] -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/MPP_PREP/src/mpp_optimiz_zoom_nc.f90
r2143 r6455 258 258 ijlb=ijdom(jni2,jnj2) 259 259 ENDIF 260 261 ! Check wet points over the entire domain to preserve the MPI communication stencil 260 262 isurf=0 261 DO jj=1 +jprecj,ippdj(jni2,jnj2)-jprecj262 DO ji=1 +jpreci,ippdi(jni2,jnj2)-jpreci263 DO jj=1,ippdj(jni2,jnj2) 264 DO ji=1,ippdi(jni2,jnj2) 263 265 IF(zmask(ji+iilb-1,jj+ijlb-1).EQ.1.) isurf=isurf+1 264 266 END DO 265 267 END DO 268 266 269 IF(isurf.EQ.0) THEN 267 270 ivide=ivide+1 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/MPP_PREP/src/mppopt_showproc_nc.f90
r2143 r6455 289 289 ijlb=ijdom(jni2,jnj2) 290 290 ENDIF 291 292 ! Check wet points over the entire domain to preserve the MPI communication stencil 291 293 isurf=0 292 293 DO jj=1+jprecj,ippdj(jni2,jnj2)-jprecj 294 DO ji=1+jpreci,ippdi(jni2,jnj2)-jpreci 294 DO jj=1,ippdj(jni2,jnj2) 295 DO ji=1,ippdi(jni2,jnj2) 295 296 IF(zmask(ji+iilb-1,jj+ijlb-1).EQ.1.) isurf=isurf+1 296 297 END DO 297 298 END DO 299 298 300 IF(isurf.EQ.0) THEN 299 301 ivide=ivide+1 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/REBUILD_NEMO/src/rebuild_nemo.f90
r3025 r6455 200 200 WRITE(numerr,*) 'Attribute DOMAIN_number_total is : ', ndomain_file 201 201 WRITE(numerr,*) 'Number of files specified in namelist is: ', ndomain 202 STOP 202 STOP 9 203 203 ENDIF 204 204 … … 268 268 WRITE(numerr,*) 'Attribute DOMAIN_local_sizes is : ', local_sizes 269 269 WRITE(numerr,*) 'Dimensions to be rebuilt are of size : ', outdimlens(rebuild_dims(1)), outdimlens(rebuild_dims(2)) 270 STOP 270 STOP 9 271 271 ENDIF 272 272 … … 384 384 SELECT CASE( xtype ) 385 385 CASE( NF90_BYTE ) 386 globaldata_0d_i1 = 0 386 387 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_i1 ) ) 387 388 CASE( NF90_SHORT ) 389 globaldata_0d_i2 = 0 388 390 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_i2 ) ) 389 391 CASE( NF90_INT ) 392 globaldata_0d_i4 = 0 390 393 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_i4 ) ) 391 394 CASE( NF90_FLOAT ) 395 globaldata_0d_sp = 0. 392 396 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_sp ) ) 393 397 CASE( NF90_DOUBLE ) 398 globaldata_0d_dp = 0. 394 399 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_0d_dp ) ) 395 400 CASE DEFAULT 396 401 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 397 STOP 402 STOP 9 398 403 END SELECT 399 404 … … 403 408 CASE( NF90_BYTE ) 404 409 ALLOCATE(globaldata_1d_i1(indimlens(dimids(1)))) 410 globaldata_1d_i1(:) = 0 405 411 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_i1 ) ) 406 412 CASE( NF90_SHORT ) 407 413 ALLOCATE(globaldata_1d_i2(indimlens(dimids(1)))) 414 globaldata_1d_i2(:) = 0 408 415 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_i2 ) ) 409 416 CASE( NF90_INT ) 410 417 ALLOCATE(globaldata_1d_i4(indimlens(dimids(1)))) 418 globaldata_1d_i4(:) = 0 411 419 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_i4 ) ) 412 420 CASE( NF90_FLOAT ) 413 421 ALLOCATE(globaldata_1d_sp(indimlens(dimids(1)))) 422 globaldata_1d_sp(:) = 0. 414 423 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_sp ) ) 415 424 CASE( NF90_DOUBLE ) 416 425 ALLOCATE(globaldata_1d_dp(indimlens(dimids(1)))) 426 globaldata_1d_dp(:) = 0. 417 427 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_1d_dp ) ) 418 428 CASE DEFAULT 419 429 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 420 STOP 430 STOP 9 421 431 END SELECT 422 432 … … 426 436 CASE( NF90_BYTE ) 427 437 ALLOCATE(globaldata_2d_i1(indimlens(dimids(1)),indimlens(dimids(2)))) 438 globaldata_2d_i1(:,:) = 0 428 439 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_i1 ) ) 429 440 CASE( NF90_SHORT ) 430 441 ALLOCATE(globaldata_2d_i2(indimlens(dimids(1)),indimlens(dimids(2)))) 442 globaldata_2d_i2(:,:) = 0 431 443 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_i2 ) ) 432 444 CASE( NF90_INT ) 433 445 ALLOCATE(globaldata_2d_i4(indimlens(dimids(1)),indimlens(dimids(2)))) 446 globaldata_2d_i4(:,:) = 0 434 447 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_i4 ) ) 435 448 CASE( NF90_FLOAT ) 436 449 ALLOCATE(globaldata_2d_sp(indimlens(dimids(1)),indimlens(dimids(2)))) 450 globaldata_2d_sp(:,:) = 0. 437 451 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_sp ) ) 438 452 CASE( NF90_DOUBLE ) 439 453 ALLOCATE(globaldata_2d_dp(indimlens(dimids(1)),indimlens(dimids(2)))) 454 globaldata_2d_dp(:,:) = 0. 440 455 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_2d_dp ) ) 441 456 CASE DEFAULT 442 457 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 443 STOP 458 STOP 9 444 459 END SELECT 445 460 … … 450 465 ALLOCATE(globaldata_3d_i1(indimlens(dimids(1)),indimlens(dimids(2)), & 451 466 & indimlens(dimids(3)))) 467 globaldata_3d_i1(:,:,:) = 0 452 468 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_i1 ) ) 453 469 CASE( NF90_SHORT ) 454 470 ALLOCATE(globaldata_3d_i2(indimlens(dimids(1)),indimlens(dimids(2)), & 455 471 & indimlens(dimids(3)))) 472 globaldata_3d_i2(:,:,:) = 0 456 473 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_i2 ) ) 457 474 CASE( NF90_INT ) 458 475 ALLOCATE(globaldata_3d_i4(indimlens(dimids(1)),indimlens(dimids(2)), & 459 476 & indimlens(dimids(3)))) 477 globaldata_3d_i4(:,:,:) = 0 460 478 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_i4 ) ) 461 479 CASE( NF90_FLOAT ) 462 480 ALLOCATE(globaldata_3d_sp(indimlens(dimids(1)),indimlens(dimids(2)), & 463 481 & indimlens(dimids(3)))) 482 globaldata_3d_sp(:,:,:) = 0. 464 483 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_sp ) ) 465 484 CASE( NF90_DOUBLE ) 466 485 ALLOCATE(globaldata_3d_dp(indimlens(dimids(1)),indimlens(dimids(2)), & 467 486 & indimlens(dimids(3)))) 487 globaldata_3d_dp(:,:,:) = 0. 468 488 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_3d_dp ) ) 469 489 CASE DEFAULT 470 490 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 471 STOP 491 STOP 9 472 492 END SELECT 473 493 … … 478 498 ALLOCATE(globaldata_4d_i1(indimlens(dimids(1)),indimlens(dimids(2)), & 479 499 & indimlens(dimids(3)),ntchunk)) 500 globaldata_4d_i1(:,:,:,:) = 0 480 501 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_i1, start=(/1,1,1,nt/) ) ) 481 502 CASE( NF90_SHORT ) 482 503 ALLOCATE(globaldata_4d_i2(indimlens(dimids(1)),indimlens(dimids(2)), & 483 504 & indimlens(dimids(3)),ntchunk)) 505 globaldata_4d_i2(:,:,:,:) = 0 484 506 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_i2, start=(/1,1,1,nt/) ) ) 485 507 CASE( NF90_INT ) 486 508 ALLOCATE(globaldata_4d_i4(indimlens(dimids(1)),indimlens(dimids(2)), & 487 509 & indimlens(dimids(3)),ntchunk)) 510 globaldata_4d_i4(:,:,:,:) = 0 488 511 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_i4, start=(/1,1,1,nt/) ) ) 489 512 CASE( NF90_FLOAT ) 490 513 ALLOCATE(globaldata_4d_sp(indimlens(dimids(1)),indimlens(dimids(2)), & 491 514 & indimlens(dimids(3)),ntchunk)) 515 globaldata_4d_sp(:,:,:,:) = 0. 492 516 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_sp, start=(/1,1,1,nt/) ) ) 493 517 CASE( NF90_DOUBLE ) 494 518 ALLOCATE(globaldata_4d_dp(indimlens(dimids(1)),indimlens(dimids(2)), & 495 519 & indimlens(dimids(3)),ntchunk)) 520 globaldata_4d_dp(:,:,:,:) = 0. 496 521 CALL check_nf90( nf90_get_var( ncid, jv, globaldata_4d_dp, start=(/1,1,1,nt/) ) ) 497 522 CASE DEFAULT 498 523 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 499 STOP 524 STOP 9 500 525 END SELECT 501 526 … … 517 542 CASE( NF90_BYTE ) 518 543 ALLOCATE(globaldata_1d_i1(outdimlens(dimids(1)))) 544 globaldata_1d_i1(:) = 0 519 545 CASE( NF90_SHORT ) 520 546 ALLOCATE(globaldata_1d_i2(outdimlens(dimids(1)))) 547 globaldata_1d_i2(:) = 0 521 548 CASE( NF90_INT ) 522 549 ALLOCATE(globaldata_1d_i4(outdimlens(dimids(1)))) 550 globaldata_1d_i4(:) = 0 523 551 CASE( NF90_FLOAT ) 524 552 ALLOCATE(globaldata_1d_sp(outdimlens(dimids(1)))) 553 globaldata_1d_sp(:) = 0. 525 554 CASE( NF90_DOUBLE ) 526 555 ALLOCATE(globaldata_1d_dp(outdimlens(dimids(1)))) 556 globaldata_1d_dp(:) = 0. 527 557 CASE DEFAULT 528 558 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 529 STOP 559 STOP 9 530 560 END SELECT 531 561 … … 535 565 CASE( NF90_BYTE ) 536 566 ALLOCATE(globaldata_2d_i1(outdimlens(dimids(1)),outdimlens(dimids(2)))) 567 globaldata_2d_i1(:,:) = 0 537 568 CASE( NF90_SHORT ) 538 569 ALLOCATE(globaldata_2d_i2(outdimlens(dimids(1)),outdimlens(dimids(2)))) 570 globaldata_2d_i2(:,:) = 0 539 571 CASE( NF90_INT ) 540 572 ALLOCATE(globaldata_2d_i4(outdimlens(dimids(1)),outdimlens(dimids(2)))) 573 globaldata_2d_i4(:,:) = 0 541 574 CASE( NF90_FLOAT ) 542 575 ALLOCATE(globaldata_2d_sp(outdimlens(dimids(1)),outdimlens(dimids(2)))) 576 globaldata_2d_sp(:,:) = 0. 543 577 CASE( NF90_DOUBLE ) 544 578 ALLOCATE(globaldata_2d_dp(outdimlens(dimids(1)),outdimlens(dimids(2)))) 579 globaldata_2d_dp(:,:) = 0. 545 580 CASE DEFAULT 546 581 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 547 STOP 582 STOP 9 548 583 END SELECT 549 584 … … 554 589 ALLOCATE(globaldata_3d_i1(outdimlens(dimids(1)),outdimlens(dimids(2)), & 555 590 & outdimlens(dimids(3)))) 591 globaldata_3d_i1(:,:,:) = 0 556 592 CASE( NF90_SHORT ) 557 593 ALLOCATE(globaldata_3d_i2(outdimlens(dimids(1)),outdimlens(dimids(2)), & 558 594 & outdimlens(dimids(3)))) 595 globaldata_3d_i2(:,:,:) = 0 559 596 CASE( NF90_INT ) 560 597 ALLOCATE(globaldata_3d_i4(outdimlens(dimids(1)),outdimlens(dimids(2)), & 561 598 & outdimlens(dimids(3)))) 599 globaldata_3d_i4(:,:,:) = 0 562 600 CASE( NF90_FLOAT ) 563 601 ALLOCATE(globaldata_3d_sp(outdimlens(dimids(1)),outdimlens(dimids(2)), & 564 602 & outdimlens(dimids(3)))) 603 globaldata_3d_sp(:,:,:) = 0. 565 604 CASE( NF90_DOUBLE ) 566 605 ALLOCATE(globaldata_3d_dp(outdimlens(dimids(1)),outdimlens(dimids(2)), & 567 606 & outdimlens(dimids(3)))) 607 globaldata_3d_dp(:,:,:) = 0. 568 608 CASE DEFAULT 569 609 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 570 STOP 610 STOP 9 571 611 END SELECT 572 612 … … 577 617 ALLOCATE(globaldata_4d_i1(outdimlens(dimids(1)),outdimlens(dimids(2)), & 578 618 & outdimlens(dimids(3)),ntchunk)) 619 globaldata_4d_i1(:,:,:,:) = 0 579 620 CASE( NF90_SHORT ) 580 621 ALLOCATE(globaldata_4d_i2(outdimlens(dimids(1)),outdimlens(dimids(2)), & 581 622 & outdimlens(dimids(3)),ntchunk)) 623 globaldata_4d_i2(:,:,:,:) = 0 582 624 CASE( NF90_INT ) 583 625 ALLOCATE(globaldata_4d_i4(outdimlens(dimids(1)),outdimlens(dimids(2)), & 584 626 & outdimlens(dimids(3)),ntchunk)) 627 globaldata_4d_i4(:,:,:,:) = 0 585 628 CASE( NF90_FLOAT ) 586 629 ALLOCATE(globaldata_4d_sp(outdimlens(dimids(1)),outdimlens(dimids(2)), & 587 630 & outdimlens(dimids(3)),ntchunk)) 631 globaldata_4d_sp(:,:,:,:) = 0. 588 632 CASE( NF90_DOUBLE ) 589 633 ALLOCATE(globaldata_4d_dp(outdimlens(dimids(1)),outdimlens(dimids(2)), & 590 634 & outdimlens(dimids(3)),ntchunk)) 635 globaldata_4d_dp(:,:,:,:) = 0. 591 636 CASE DEFAULT 592 637 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 593 STOP 638 STOP 9 594 639 END SELECT 595 640 ELSE 596 641 WRITE(numerr,*) 'ERROR! : A netcdf variable has more than 4 dimensions which is not taken into account' 597 STOP 642 STOP 9 598 643 ENDIF 599 644 … … 967 1012 IF( nthreads == 1 .AND. istop /= nf90_noerr ) THEN 968 1013 WRITE(numerr,*) '*** NEMO rebuild failed! ***' 969 STOP 1014 STOP 9 970 1015 ENDIF 971 1016 … … 976 1021 IF( istop /= nf90_noerr ) THEN 977 1022 WRITE(numerr,*) '*** NEMO rebuild failed! ***' 978 STOP 1023 STOP 9 979 1024 ENDIF 980 1025 … … 1050 1095 CASE DEFAULT 1051 1096 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 1052 STOP 1097 STOP 9 1053 1098 END SELECT 1054 1099 … … 1073 1118 CASE DEFAULT 1074 1119 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 1075 STOP 1120 STOP 9 1076 1121 END SELECT 1077 1122 … … 1096 1141 CASE DEFAULT 1097 1142 WRITE(numerr,*) 'Unknown nf90 type: ', xtype 1098 STOP 1143 STOP 9 1099 1144 END SELECT 1100 1145 … … 1146 1191 WRITE(numerr,*) "*** NEMO rebuild failed ***" 1147 1192 WRITE(numerr,*) 1148 STOP 1193 STOP 9 1149 1194 ENDIF 1150 1195 ENDIF -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/cfg/variable.cfg
r5616 r6455 1 1 # name | units | axis | pt| interpolation | long name | standard name 2 X | 1| X | | | | projection_x_coordinate3 Y | 1| Y | | | | projection_y_coordinate4 Z | 1| Z | | | | projection_z_coordinate5 T | 1| T | | | | projection_t_coordinate2 X | unitless | X | | | | projection_x_coordinate 3 Y | unitless | Y | | | | projection_y_coordinate 4 Z | unitless | Z | | | | projection_z_coordinate 5 T | unitless | T | | | | projection_t_coordinate 6 6 nav_lon | degrees_east | XY | T | cubic | Longitude | longitude 7 7 nav_lat | degrees_north | XY | T | cubic | Latitude | latitude -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/Doxyfile
r5037 r6455 45 45 # quick idea about the purpose of the project. Keep the description short. 46 46 47 PROJECT_BRIEF = "System and Interface for oceanic REloca ble Nesting"47 PROJECT_BRIEF = "System and Interface for oceanic RElocatable Nesting" 48 48 49 49 # With the PROJECT_LOGO tag one can specify an logo or icon that is included in … … 2069 2069 # The default value is: NO. 2070 2070 2071 HAVE_DOT = YES2071 HAVE_DOT = NO 2072 2072 2073 2073 # The DOT_NUM_THREADS specifies the number of dot invocations doxygen is allowed -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/attribute.f90
r5616 r6455 83 83 !> @date November, 2014 84 84 !> - Fix memory leaks bug 85 !> @date September, 2015 86 !> - manage useless (dummy) attributes 85 87 ! 86 88 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 98 100 PUBLIC :: TATT !< attribute structure 99 101 102 PRIVATE :: cm_dumatt !< dummy attribute array 103 100 104 ! function and subroutine 101 105 PUBLIC :: att_init !< initialize attribute structure … … 105 109 PUBLIC :: att_get_index !< get attribute index, in an array of attribute structure 106 110 PUBLIC :: att_get_id !< get attribute id, read from file 111 PUBLIC :: att_get_dummy !< fill dummy attribute array 112 PUBLIC :: att_is_dummy !< check if attribute is defined as dummy attribute 107 113 108 114 PRIVATE :: att__clean_unit ! clean attribute strcuture … … 135 141 END TYPE TATT 136 142 143 CHARACTER(LEN=lc), DIMENSION(ip_maxdum), SAVE :: cm_dumatt !< dummy attribute 144 137 145 INTERFACE att_init 138 146 MODULE PROCEDURE att__init_c … … 1251 1259 1252 1260 END SUBROUTINE att__clean_arr 1261 !------------------------------------------------------------------- 1262 !> @brief This subroutine fill dummy attribute array 1263 ! 1264 !> @author J.Paul 1265 !> @date September, 2015 - Initial Version 1266 !> @date Marsh, 2016 1267 !> - close file (bugfix) 1268 ! 1269 !> @param[in] cd_dummy dummy configuration file 1270 !------------------------------------------------------------------- 1271 SUBROUTINE att_get_dummy( cd_dummy ) 1272 IMPLICIT NONE 1273 ! Argument 1274 CHARACTER(LEN=*), INTENT(IN) :: cd_dummy 1275 1276 ! local variable 1277 INTEGER(i4) :: il_fileid 1278 INTEGER(i4) :: il_status 1279 1280 LOGICAL :: ll_exist 1281 1282 ! loop indices 1283 ! namelist 1284 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumvar 1285 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumdim 1286 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumatt 1287 1288 !---------------------------------------------------------------- 1289 NAMELIST /namdum/ & !< dummy namelist 1290 & cn_dumvar, & !< variable name 1291 & cn_dumdim, & !< dimension name 1292 & cn_dumatt !< attribute name 1293 !---------------------------------------------------------------- 1294 1295 ! init 1296 cm_dumatt(:)='' 1297 1298 ! read namelist 1299 INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) 1300 IF( ll_exist )THEN 1301 1302 il_fileid=fct_getunit() 1303 1304 OPEN( il_fileid, FILE=TRIM(cd_dummy), & 1305 & FORM='FORMATTED', & 1306 & ACCESS='SEQUENTIAL', & 1307 & STATUS='OLD', & 1308 & ACTION='READ', & 1309 & IOSTAT=il_status) 1310 CALL fct_err(il_status) 1311 IF( il_status /= 0 )THEN 1312 CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) 1313 ENDIF 1314 1315 READ( il_fileid, NML = namdum ) 1316 cm_dumatt(:)=cn_dumatt(:) 1317 1318 CLOSE( il_fileid ) 1319 1320 ENDIF 1321 1322 END SUBROUTINE att_get_dummy 1323 !------------------------------------------------------------------- 1324 !> @brief This function check if attribute is defined as dummy attribute 1325 !> in configuraton file 1326 !> 1327 !> @author J.Paul 1328 !> @date September, 2015 - Initial Version 1329 ! 1330 !> @param[in] td_att attribute structure 1331 !> @return true if attribute is dummy attribute 1332 !------------------------------------------------------------------- 1333 FUNCTION att_is_dummy(td_att) 1334 IMPLICIT NONE 1335 1336 ! Argument 1337 TYPE(TATT), INTENT(IN) :: td_att 1338 1339 ! function 1340 LOGICAL :: att_is_dummy 1341 1342 ! loop indices 1343 INTEGER(i4) :: ji 1344 !---------------------------------------------------------------- 1345 1346 att_is_dummy=.FALSE. 1347 DO ji=1,ip_maxdum 1348 IF( fct_lower(td_att%c_name) == fct_lower(cm_dumatt(ji)) )THEN 1349 att_is_dummy=.TRUE. 1350 EXIT 1351 ENDIF 1352 ENDDO 1353 1354 END FUNCTION att_is_dummy 1253 1355 END MODULE att 1254 1356 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/boundary.f90
r5608 r6455 482 482 !> ex : cn_north='index1,first1,last1(width)|index2,first2,last2' 483 483 !> 484 !> @ noteBoundaries are compute on T point, but expressed on U,V point.484 !> @warn Boundaries are compute on T point, but expressed on U,V point. 485 485 !> change will be done to get data on other point when need be. 486 486 !> -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/create_bathy.f90
r5616 r6455 8 8 !> @file 9 9 !> @brief 10 !> This program create fine grid bathymetry file.10 !> This program creates fine grid bathymetry file. 11 11 !> 12 12 !> @details … … 27 27 !> you could find a template of the namelist in templates directory. 28 28 !> 29 !> create_bathy.nam co mprise7 namelists:<br/>29 !> create_bathy.nam contains 7 namelists:<br/> 30 30 !> - logger namelist (namlog) 31 31 !> - config namelist (namcfg) … … 36 36 !> - output namelist (namout) 37 37 !> 38 !> @note39 !> All namelists have to be in file create_bathy.nam, however variables of40 !> those namelists are all optional.41 !>42 38 !> * _logger namelist (namlog)_:<br/> 43 39 !> - cn_logfile : log filename … … 49 45 !> - cn_varcfg : variable configuration file 50 46 !> (see ./SIREN/cfg/variable.cfg) 47 !> - cn_dumcfg : useless (dummy) configuration file, for useless 48 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 51 49 !> 52 50 !> * _coarse grid namelist (namcrs)_:<br/> … … 61 59 !> 62 60 !> * _variable namelist (namvar)_:<br/> 63 !> - cn_varinfo : list of variable and extra information about request(s)64 !> to be used.<br/>65 !> each elements of *cn_varinfo* is a string character66 !> (separated by ',').<br/>67 !> it is composed of the variable name follow by ':',68 !> then request(s) to be used on this variable.<br/>69 !> request could be:70 !> - int = interpolation method71 !> - ext = extrapolation method72 !> - flt = filter method73 !> - min = minimum value74 !> - max = maximum value75 !> - unt = new units76 !> - unf = unit scale factor (linked to new units)77 !>78 !> requests must be separated by ';'.<br/>79 !> order of requests does not matter.<br/>80 !>81 !> informations about available method could be find in @ref interp,82 !> @ref extrap and @ref filter modules.<br/>83 !> Example: 'Bathymetry: flt=2*hamming(2,3); min=0'84 !> @note85 !> If you do not specify a method which is required,86 !> default one is apply.87 !> @warning88 !> variable name must be __Bathymetry__ here.89 61 !> - cn_varfile : list of variable, and corresponding file.<br/> 90 62 !> *cn_varfile* is the path and filename of the file where find … … 108 80 !> - 'Bathymetry:5000,5000,5000/5000,3000,5000/5000,5000,5000' 109 81 !> 82 !> - cn_varinfo : list of variable and extra information about request(s) 83 !> to be used.<br/> 84 !> each elements of *cn_varinfo* is a string character 85 !> (separated by ',').<br/> 86 !> it is composed of the variable name follow by ':', 87 !> then request(s) to be used on this variable.<br/> 88 !> request could be: 89 !> - int = interpolation method 90 !> - ext = extrapolation method 91 !> - flt = filter method 92 !> - min = minimum value 93 !> - max = maximum value 94 !> - unt = new units 95 !> - unf = unit scale factor (linked to new units) 96 !> 97 !> requests must be separated by ';'.<br/> 98 !> order of requests does not matter.<br/> 99 !> 100 !> informations about available method could be find in @ref interp, 101 !> @ref extrap and @ref filter modules.<br/> 102 !> Example: 'Bathymetry: flt=2*hamming(2,3); min=0' 103 !> @note 104 !> If you do not specify a method which is required, 105 !> default one is apply. 106 !> @warning 107 !> variable name must be __Bathymetry__ here. 108 !> 110 109 !> * _nesting namelist (namnst)_:<br/> 111 110 !> - in_rhoi : refinement factor in i-direction … … 127 126 !> - extrapolate all land points. 128 127 !> - allow to change unit. 128 !> @date September, 2015 129 !> - manage useless (dummy) variable, attributes, and dimension 130 !> @date January,2016 131 !> - add create_bathy_check_depth as in create_boundary 132 !> - add create_bathy_check_time as in create_boundary 133 !> @date February, 2016 134 !> - do not closed sea for east-west cyclic domain 129 135 ! 130 136 !> @todo 131 !> - use create_bathy_check_depth as in create_boundary132 !> - use create_bathy_check_time as in create_boundary133 137 !> - check tl_multi is not empty 134 138 !> … … 167 171 INTEGER(i4) :: il_status 168 172 INTEGER(i4) :: il_fileid 169 INTEGER(i4) :: il_varid170 173 INTEGER(i4) :: il_attid 171 174 INTEGER(i4) :: il_imin0 … … 179 182 180 183 LOGICAL :: ll_exist 184 LOGICAL :: ll_fillclosed 181 185 182 186 TYPE(TMPP) :: tl_coord0 … … 208 212 ! namelist variable 209 213 ! namlog 210 CHARACTER(LEN=lc) :: cn_logfile = 'create_bathy.log'211 CHARACTER(LEN=lc) :: cn_verbosity = 'warning'212 INTEGER(i4) :: in_maxerror = 5214 CHARACTER(LEN=lc) :: cn_logfile = 'create_bathy.log' 215 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 216 INTEGER(i4) :: in_maxerror = 5 213 217 214 218 ! namcfg 215 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 219 CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' 220 CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' 216 221 217 222 ! namcrs 218 CHARACTER(LEN=lc) :: cn_coord0 = ''219 INTEGER(i4) :: in_perio0 = -1223 CHARACTER(LEN=lc) :: cn_coord0 = '' 224 INTEGER(i4) :: in_perio0 = -1 220 225 221 226 ! namfin 222 CHARACTER(LEN=lc) :: cn_coord1 = ''223 INTEGER(i4) :: in_perio1 = -1224 LOGICAL :: ln_fillclosed = .TRUE.227 CHARACTER(LEN=lc) :: cn_coord1 = '' 228 INTEGER(i4) :: in_perio1 = -1 229 LOGICAL :: ln_fillclosed = .TRUE. 225 230 226 231 ! namvar 232 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' 227 233 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 228 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''229 234 230 235 ! namnst 231 INTEGER(i4) :: in_rhoi = 1232 INTEGER(i4) :: in_rhoj = 1236 INTEGER(i4) :: in_rhoi = 1 237 INTEGER(i4) :: in_rhoj = 1 233 238 234 239 ! namout 235 CHARACTER(LEN=lc) :: cn_fileout = 'bathy_fine.nc'240 CHARACTER(LEN=lc) :: cn_fileout = 'bathy_fine.nc' 236 241 !------------------------------------------------------------------- 237 242 … … 242 247 243 248 NAMELIST /namcfg/ & !< configuration namelist 244 & cn_varcfg !< variable configuration file 249 & cn_varcfg, & !< variable configuration file 250 & cn_dumcfg !< dummy configuration file 245 251 246 252 NAMELIST /namcrs/ & !< coarse grid namelist … … 254 260 255 261 NAMELIST /namvar/ & !< variable namelist 256 & cn_var info, & !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' )257 & cn_var file !< list of variable file262 & cn_varfile, & !< list of variable file 263 & cn_varinfo !< list of variable and interpolation method to be used. (ex: 'votemper:linear','vosaline:cubic' ) 258 264 259 265 NAMELIST /namnst/ & !< nesting namelist … … 302 308 CALL var_def_extra(TRIM(cn_varcfg)) 303 309 310 ! get dummy variable 311 CALL var_get_dummy(TRIM(cn_dumcfg)) 312 ! get dummy dimension 313 CALL dim_get_dummy(TRIM(cn_dumcfg)) 314 ! get dummy attribute 315 CALL att_get_dummy(TRIM(cn_dumcfg)) 316 304 317 READ( il_fileid, NML = namcrs ) 305 318 READ( il_fileid, NML = namfin ) … … 309 322 ! match variable with file 310 323 tl_multi=multi_init(cn_varfile) 311 324 312 325 READ( il_fileid, NML = namnst ) 313 326 READ( il_fileid, NML = namout ) … … 322 335 323 336 PRINT *,"ERROR in create_bathy: can't find "//TRIM(cl_namelist) 337 STOP 324 338 325 339 ENDIF … … 343 357 & "check namelist") 344 358 ENDIF 359 360 ! do not closed sea for east-west cyclic domain 361 ll_fillclosed=ln_fillclosed 362 IF( tl_coord1%i_perio == 1 ) ll_fillclosed=.FALSE. 345 363 346 364 ! check … … 417 435 418 436 ! get or check depth value 419 IF( tl_multi%t_mpp(ji)%t_proc(1)%i_depthid /= 0 )THEN 420 il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_depthid 421 IF( ASSOCIATED(tl_depth%d_value) )THEN 422 tl_tmp=iom_mpp_read_var(tl_mpp,il_varid) 423 IF( ANY( tl_depth%d_value(:,:,:,:) /= & 424 & tl_tmp%d_value(:,:,:,:) ) )THEN 425 CALL logger_fatal("CREATE BATHY: depth value from "//& 426 & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//& 427 & " to those from former file(s).") 428 ENDIF 429 CALL var_clean(tl_tmp) 430 ELSE 431 tl_depth=iom_mpp_read_var(tl_mpp,il_varid) 432 ENDIF 433 ENDIF 437 CALL create_bathy_check_depth( tl_mpp, tl_depth ) 434 438 435 439 ! get or check time value 436 IF( tl_multi%t_mpp(ji)%t_proc(1)%i_timeid /= 0 )THEN 437 il_varid=tl_multi%t_mpp(ji)%t_proc(1)%i_timeid 438 IF( ASSOCIATED(tl_time%d_value) )THEN 439 tl_tmp=iom_mpp_read_var(tl_mpp,il_varid) 440 IF( ANY( tl_time%d_value(:,:,:,:) /= & 441 & tl_tmp%d_value(:,:,:,:) ) )THEN 442 CALL logger_fatal("CREATE BATHY: time value from "//& 443 & TRIM(tl_multi%t_mpp(ji)%c_name)//" not conform "//& 444 & " to those from former file(s).") 445 ENDIF 446 CALL var_clean(tl_tmp) 447 ELSE 448 tl_time=iom_mpp_read_var(tl_mpp,il_varid) 449 ENDIF 450 ENDIF 440 CALL create_bathy_check_time( tl_mpp, tl_time ) 451 441 452 442 ! close mpp file 453 443 CALL iom_mpp_close(tl_mpp) 454 444 455 IF( ANY( tl_mpp%t_dim(1:2)%i_len /=&456 & tl_coord0%t_dim(1:2)%i_len) )THEN445 IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len).OR.& 446 & ALL(il_rho(:)==1) )THEN 457 447 !- extract bathymetry from fine grid bathymetry 458 448 DO jj=1,tl_multi%t_mpp(ji)%t_proc(1)%i_nvar … … 505 495 506 496 ! fill closed sea 507 IF( l n_fillclosed )THEN497 IF( ll_fillclosed )THEN 508 498 ALLOCATE( il_mask(tl_var(jk)%t_dim(1)%i_len, & 509 499 & tl_var(jk)%t_dim(2)%i_len) ) … … 526 516 & dl_minbat <= 0._dp )THEN 527 517 CALL logger_debug("CREATE BATHY: min value "//TRIM(fct_str(dl_minbat))) 528 CALL logger_ error("CREATE BATHY: Bathymetry has value <= 0")518 CALL logger_fatal("CREATE BATHY: Bathymetry has value <= 0") 529 519 ENDIF 530 520 … … 973 963 CALL dom_del_extra( tl_var, tl_dom, il_rho(:) ) 974 964 965 CALL dom_clean_extra( tl_dom ) 966 975 967 !- add ghost cell 976 968 CALL grid_add_ghost(tl_var,tl_dom%i_ghost(:,:)) … … 1109 1101 1110 1102 END SUBROUTINE create_bathy_interp 1103 !------------------------------------------------------------------- 1104 !> @brief 1105 !> This subroutine get depth variable value in an open mpp structure 1106 !> and check if agree with already input depth variable. 1107 !> 1108 !> @details 1109 !> 1110 !> @author J.Paul 1111 !> @date January, 2016 - Initial Version 1112 !> 1113 !> @param[in] td_mpp mpp structure 1114 !> @param[inout] td_depth depth variable structure 1115 !------------------------------------------------------------------- 1116 SUBROUTINE create_bathy_check_depth( td_mpp, td_depth ) 1117 1118 IMPLICIT NONE 1119 1120 ! Argument 1121 TYPE(TMPP) , INTENT(IN ) :: td_mpp 1122 TYPE(TVAR) , INTENT(INOUT) :: td_depth 1123 1124 ! local variable 1125 INTEGER(i4) :: il_varid 1126 TYPE(TVAR) :: tl_depth 1127 ! loop indices 1128 !---------------------------------------------------------------- 1129 1130 ! get or check depth value 1131 IF( td_mpp%t_proc(1)%i_depthid /= 0 )THEN 1132 1133 il_varid=td_mpp%t_proc(1)%i_depthid 1134 IF( ASSOCIATED(td_depth%d_value) )THEN 1135 1136 tl_depth=iom_mpp_read_var(td_mpp, il_varid) 1137 1138 IF( ANY( td_depth%d_value(:,:,:,:) /= & 1139 & tl_depth%d_value(:,:,:,:) ) )THEN 1140 1141 CALL logger_warn("CREATE BATHY: depth value from "//& 1142 & TRIM(td_mpp%c_name)//" not conform "//& 1143 & " to those from former file(s).") 1144 1145 ENDIF 1146 CALL var_clean(tl_depth) 1147 1148 ELSE 1149 td_depth=iom_mpp_read_var(td_mpp,il_varid) 1150 ENDIF 1151 1152 ENDIF 1153 1154 END SUBROUTINE create_bathy_check_depth 1155 !------------------------------------------------------------------- 1156 !> @brief 1157 !> This subroutine get date and time in an open mpp structure 1158 !> and check if agree with date and time already read. 1159 !> 1160 !> @details 1161 !> 1162 !> @author J.Paul 1163 !> @date January, 2016 - Initial Version 1164 !> 1165 !> @param[in] td_mpp mpp structure 1166 !> @param[inout] td_time time variable structure 1167 !------------------------------------------------------------------- 1168 SUBROUTINE create_bathy_check_time( td_mpp, td_time ) 1169 1170 IMPLICIT NONE 1171 1172 ! Argument 1173 TYPE(TMPP), INTENT(IN ) :: td_mpp 1174 TYPE(TVAR), INTENT(INOUT) :: td_time 1175 1176 ! local variable 1177 INTEGER(i4) :: il_varid 1178 TYPE(TVAR) :: tl_time 1179 1180 TYPE(TDATE) :: tl_date1 1181 TYPE(TDATE) :: tl_date2 1182 ! loop indices 1183 !---------------------------------------------------------------- 1184 1185 ! get or check depth value 1186 IF( td_mpp%t_proc(1)%i_timeid /= 0 )THEN 1187 1188 il_varid=td_mpp%t_proc(1)%i_timeid 1189 IF( ASSOCIATED(td_time%d_value) )THEN 1190 1191 tl_time=iom_mpp_read_var(td_mpp, il_varid) 1192 1193 tl_date1=var_to_date(td_time) 1194 tl_date2=var_to_date(tl_time) 1195 IF( tl_date1 - tl_date2 /= 0 )THEN 1196 1197 CALL logger_warn("CREATE BATHY: date from "//& 1198 & TRIM(td_mpp%c_name)//" not conform "//& 1199 & " to those from former file(s).") 1200 1201 ENDIF 1202 CALL var_clean(tl_time) 1203 1204 ELSE 1205 td_time=iom_mpp_read_var(td_mpp,il_varid) 1206 ENDIF 1207 1208 ENDIF 1209 1210 END SUBROUTINE create_bathy_check_time 1111 1211 END PROGRAM create_bathy -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/create_coord.f90
r5608 r6455 9 9 !> @file 10 10 !> @brief 11 !> This program create fine grid coordinate file.11 !> This program creates fine grid coordinate file. 12 12 !> 13 13 !> @details … … 27 27 !> you could find a template of the namelist in templates directory. 28 28 !> 29 !> create_coord.nam co mprise6 namelists:<br/>29 !> create_coord.nam contains 6 namelists:<br/> 30 30 !> - logger namelist (namlog) 31 31 !> - config namelist (namcfg) … … 35 35 !> - output namelist (namout) 36 36 !> 37 !> @note38 !> All namelists have to be in file create_coord.nam,39 !> however variables of those namelists are all optional.40 !>41 37 !> * _logger namelist (namlog)_:<br/> 42 38 !> - cn_logfile : log filename … … 48 44 !> - cn_varcfg : variable configuration file 49 45 !> (see ./SIREN/cfg/variable.cfg) 46 !> - cn_dumcfg : useless (dummy) configuration file, for useless 47 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 50 48 !> 51 49 !> * _coarse grid namelist (namcrs)_:<br/> … … 64 62 !> - int = interpolation method 65 63 !> - ext = extrapolation method 66 !> - flt = filter method67 64 !> 68 65 !> requests must be separated by ';' .<br/> … … 72 69 !> @ref extrap and @ref filter modules.<br/> 73 70 !> 74 !> Example: ' votemper: int=linear; flt=hann(2,3); ext=dist_weight',75 !> ' vosaline: int=cubic'<br/>71 !> Example: 'glamt: int=linear; ext=dist_weight', 72 !> 'e1t: int=cubic/rhoi'<br/> 76 73 !> @note 77 74 !> If you do not specify a method which is required, … … 103 100 !> - compute offset considering grid point 104 101 !> - add global attributes in output file 102 !> @date September, 2015 103 !> - manage useless (dummy) variable, attributes, and dimension 105 104 !> 106 105 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 167 166 168 167 ! namcfg 169 CHARACTER(LEN=lc) :: cn_varcfg = '../cfg/variable.cfg' 168 CHARACTER(LEN=lc) :: cn_varcfg = './cfg/variable.cfg' 169 CHARACTER(LEN=lc) :: cn_dumcfg = './cfg/dummy.cfg' 170 170 171 171 ! namcrs … … 194 194 195 195 NAMELIST /namcfg/ & ! config namelist 196 & cn_varcfg !< variable configuration file 196 & cn_varcfg, & !< variable configuration file 197 & cn_dumcfg !< dummy configuration file 197 198 198 199 NAMELIST /namcrs/ & ! coarse grid namelist … … 254 255 CALL var_def_extra(TRIM(cn_varcfg)) 255 256 257 ! get dummy variable 258 CALL var_get_dummy(TRIM(cn_dumcfg)) 259 ! get dummy dimension 260 CALL dim_get_dummy(TRIM(cn_dumcfg)) 261 ! get dummy attribute 262 CALL att_get_dummy(TRIM(cn_dumcfg)) 263 256 264 READ( il_fileid, NML = namcrs ) 257 265 READ( il_fileid, NML = namvar ) … … 354 362 ENDDO 355 363 364 ! clean 365 CALL dom_clean_extra( tl_dom ) 366 356 367 ! close mpp files 357 368 CALL iom_dom_close(tl_coord0) … … 388 399 CALL file_add_att(tl_fileout, tl_att) 389 400 390 tl_att=att_init("src_i_indices",(/ in_imin0,in_imax0/))401 tl_att=att_init("src_i_indices",(/tl_dom%i_imin,tl_dom%i_imax/)) 391 402 CALL file_add_att(tl_fileout, tl_att) 392 tl_att=att_init("src_j_indices",(/ in_jmin0,in_jmax0/))403 tl_att=att_init("src_j_indices",(/tl_dom%i_jmin,tl_dom%i_jmax/)) 393 404 CALL file_add_att(tl_fileout, tl_att) 394 405 IF( .NOT. ALL(il_rho(:)==1) )THEN -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/create_restart.f90
r5616 r6455 9 9 !> @file 10 10 !> @brief 11 !> This program create restart file.11 !> This program creates restart file. 12 12 !> 13 13 !> @details 14 14 !> @section sec1 method 15 15 !> Variables could be extracted from fine grid file, interpolated from coarse 16 !> grid file or restart file , ormanually written.<br/>17 !> Then they are split over new decomposition.16 !> grid file or restart file. Variables could also be manually written.<br/> 17 !> Then they are split over new layout. 18 18 !> @note 19 19 !> method could be different for each variable. … … 28 28 !> you could find a template of the namelist in templates directory. 29 29 !> 30 !> create_restart.nam co mprise9 namelists:<br/>30 !> create_restart.nam contains 9 namelists:<br/> 31 31 !> - logger namelist (namlog) 32 32 !> - config namelist (namcfg) … … 39 39 !> - output namelist (namout) 40 40 !> 41 !> @note42 !> All namelists have to be in file create_restart.nam43 !> however variables of those namelists are all optional.44 !>45 41 !> * _logger namelist (namlog)_:<br/> 46 42 !> - cn_logfile : log filename … … 52 48 !> - cn_varcfg : variable configuration file 53 49 !> (see ./SIREN/cfg/variable.cfg) 50 !> - cn_dumcfg : useless (dummy) configuration file, for useless 51 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 54 52 !> 55 53 !> * _coarse grid namelist (namcrs):<br/> … … 82 80 !> 83 81 !> * _variable namelist (namvar)_:<br/> 84 !> - cn_varinfo : list of variable and extra information about request(s) 85 !> to be used.<br/> 86 !> each elements of *cn_varinfo* is a string character 87 !> (separated by ',').<br/> 88 !> it is composed of the variable name follow by ':', 89 !> then request(s) to be used on this variable.<br/> 90 !> request could be: 91 !> - int = interpolation method 92 !> - ext = extrapolation method 93 !> - flt = filter method 94 !> - min = minimum value 95 !> - max = maximum value 96 !> - unt = new units 97 !> - unf = unit scale factor (linked to new units) 98 !> 99 !> requests must be separated by ';'.<br/> 100 !> order of requests does not matter.<br/> 101 !> 102 !> informations about available method could be find in @ref interp, 103 !> @ref extrap and @ref filter.<br/> 104 !> Example: 'votemper: int=linear; flt=hann; ext=dist_weight','vosaline: int=cubic' 105 !> @note 106 !> If you do not specify a method which is required, 107 !> default one is apply. 108 !> - cn_varfile : list of variable, and corresponding file<br/> 82 !> - cn_varfile : list of variable, and associated file<br/> 109 83 !> *cn_varfile* is the path and filename of the file where find 110 84 !> variable.<br/> … … 131 105 !> - 'all:restart.dimg' 132 106 !> 107 !> - cn_varinfo : list of variable and extra information about request(s) 108 !> to be used.<br/> 109 !> each elements of *cn_varinfo* is a string character 110 !> (separated by ',').<br/> 111 !> it is composed of the variable name follow by ':', 112 !> then request(s) to be used on this variable.<br/> 113 !> request could be: 114 !> - int = interpolation method 115 !> - ext = extrapolation method 116 !> - flt = filter method 117 !> - min = minimum value 118 !> - max = maximum value 119 !> - unt = new units 120 !> - unf = unit scale factor (linked to new units) 121 !> 122 !> requests must be separated by ';'.<br/> 123 !> order of requests does not matter.<br/> 124 !> 125 !> informations about available method could be find in @ref interp, 126 !> @ref extrap and @ref filter.<br/> 127 !> Example: 'votemper: int=linear; flt=hann; ext=dist_weight', 128 !> 'vosaline: int=cubic' 129 !> @note 130 !> If you do not specify a method which is required, 131 !> default one is apply. 132 !> 133 133 !> * _nesting namelist (namnst)_:<br/> 134 134 !> - in_rhoi : refinement factor in i-direction 135 135 !> - in_rhoj : refinement factor in j-direction 136 136 !> @note 137 !> coarse grid indices will be deduced from fine grid137 !> coarse grid indices will be computed from fine grid 138 138 !> coordinate file. 139 139 !> … … 141 141 !> - cn_fileout : output file 142 142 !> - ln_extrap : extrapolate land point or not 143 !> - in_niproc : i-direction number of processor144 !> - in_njproc : j-direction numebr of processor143 !> - in_niproc : number of processor in i-direction 144 !> - in_njproc : number of processor in j-direction 145 145 !> - in_nproc : total number of processor to be used 146 146 !> - cn_type : output format ('dimg', 'cdf') … … 156 156 !> - extrapolate all land points, and add ln_extrap in namelist. 157 157 !> - allow to change unit. 158 !> @date September, 2015 159 !> - manage useless (dummy) variable, attributes, and dimension 158 160 !> 159 161 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 173 175 USE iom ! I/O manager 174 176 USE grid ! grid manager 175 USE vgrid 177 USE vgrid ! vertical grid manager 176 178 USE extrap ! extrapolation manager 177 179 USE interp ! interpolation manager … … 183 185 184 186 IMPLICIT NONE 185 186 187 187 188 ! local variable … … 212 213 213 214 LOGICAL :: ll_exist 215 LOGICAL :: ll_sameGrid 214 216 215 217 TYPE(TDOM) :: tl_dom1 … … 242 244 ! namelist variable 243 245 ! namlog 244 CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log'245 CHARACTER(LEN=lc) :: cn_verbosity = 'warning'246 INTEGER(i4) :: in_maxerror = 5246 CHARACTER(LEN=lc) :: cn_logfile = 'create_restart.log' 247 CHARACTER(LEN=lc) :: cn_verbosity = 'warning' 248 INTEGER(i4) :: in_maxerror = 5 247 249 248 250 ! namcfg 249 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 251 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 252 CHARACTER(LEN=lc) :: cn_dumcfg = 'dummy.cfg' 250 253 251 254 ! namcrs 252 CHARACTER(LEN=lc) :: cn_coord0 = ''253 INTEGER(i4) :: in_perio0 = -1255 CHARACTER(LEN=lc) :: cn_coord0 = '' 256 INTEGER(i4) :: in_perio0 = -1 254 257 255 258 ! namfin 256 CHARACTER(LEN=lc) :: cn_coord1 = ''257 CHARACTER(LEN=lc) :: cn_bathy1 = ''258 INTEGER(i4) :: in_perio1 = -1259 CHARACTER(LEN=lc) :: cn_coord1 = '' 260 CHARACTER(LEN=lc) :: cn_bathy1 = '' 261 INTEGER(i4) :: in_perio1 = -1 259 262 260 263 !namzgr 261 REAL(dp) :: dn_pp_to_be_computed = 0._dp262 REAL(dp) :: dn_ppsur= -3958.951371276829_dp263 REAL(dp) :: dn_ppa0 = 103.9530096000000_dp264 REAL(dp) :: dn_ppa1 = 2.4159512690000_dp265 REAL(dp) :: dn_ppa2 = 100.7609285000000_dp266 REAL(dp) :: dn_ppkth = 15.3510137000000_dp267 REAL(dp) :: dn_ppkth2 = 48.0298937200000_dp268 REAL(dp) :: dn_ppacr = 7.0000000000000_dp269 REAL(dp) :: dn_ppacr2= 13.000000000000_dp270 REAL(dp) :: dn_ppdzmin= 6._dp271 REAL(dp) :: dn_pphmax= 5750._dp272 INTEGER(i4) :: in_nlevel= 75264 REAL(dp) :: dn_pp_to_be_computed = 0._dp 265 REAL(dp) :: dn_ppsur = -3958.951371276829_dp 266 REAL(dp) :: dn_ppa0 = 103.953009600000_dp 267 REAL(dp) :: dn_ppa1 = 2.415951269000_dp 268 REAL(dp) :: dn_ppa2 = 100.760928500000_dp 269 REAL(dp) :: dn_ppkth = 15.351013700000_dp 270 REAL(dp) :: dn_ppkth2 = 48.029893720000_dp 271 REAL(dp) :: dn_ppacr = 7.000000000000_dp 272 REAL(dp) :: dn_ppacr2 = 13.000000000000_dp 273 REAL(dp) :: dn_ppdzmin = 6._dp 274 REAL(dp) :: dn_pphmax = 5750._dp 275 INTEGER(i4) :: in_nlevel = 75 273 276 274 277 !namzps 275 REAL(dp) :: dn_e3zps_min = 25._dp276 REAL(dp) :: dn_e3zps_rat = 0.2_dp278 REAL(dp) :: dn_e3zps_min = 25._dp 279 REAL(dp) :: dn_e3zps_rat = 0.2_dp 277 280 278 281 ! namvar 282 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = '' 279 283 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 280 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varfile = ''281 284 282 285 ! namnst 283 INTEGER(i4) :: in_rhoi = 0284 INTEGER(i4) :: in_rhoj = 0286 INTEGER(i4) :: in_rhoi = 0 287 INTEGER(i4) :: in_rhoj = 0 285 288 286 289 ! namout 287 CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc'288 LOGICAL :: ln_extrap = .FALSE.289 INTEGER(i4) :: in_nproc = 0290 INTEGER(i4) :: in_niproc = 0291 INTEGER(i4) :: in_njproc = 0292 CHARACTER(LEN=lc) :: cn_type = ''290 CHARACTER(LEN=lc) :: cn_fileout = 'restart.nc' 291 LOGICAL :: ln_extrap = .FALSE. 292 INTEGER(i4) :: in_nproc = 0 293 INTEGER(i4) :: in_niproc = 0 294 INTEGER(i4) :: in_njproc = 0 295 CHARACTER(LEN=lc) :: cn_type = '' 293 296 294 297 !------------------------------------------------------------------- … … 300 303 301 304 NAMELIST /namcfg/ & !< configuration namelist 302 & cn_varcfg !< variable configuration file 305 & cn_varcfg, & !< variable configuration file 306 & cn_dumcfg !< dummy configuration file 303 307 304 308 NAMELIST /namcrs/ & !< coarse grid namelist … … 330 334 331 335 NAMELIST /namvar/ & !< variable namelist 332 & cn_var info, & !< list of variable and interpolation method to be used.333 & cn_var file !< list of variable file336 & cn_varfile, & !< list of variable file 337 & cn_varinfo !< list of variable and interpolation method to be used. 334 338 335 339 NAMELIST /namnst/ & !< nesting namelist … … 382 386 ! get variable extra information 383 387 CALL var_def_extra(TRIM(cn_varcfg)) 388 389 ! get dummy variable 390 CALL var_get_dummy(TRIM(cn_dumcfg)) 391 ! get dummy dimension 392 CALL dim_get_dummy(TRIM(cn_dumcfg)) 393 ! get dummy attribute 394 CALL att_get_dummy(TRIM(cn_dumcfg)) 384 395 385 396 READ( il_fileid, NML = namcrs ) … … 509 520 510 521 jvar=jvar+1 511 522 512 523 WRITE(*,'(2x,a,a)') "work on variable "//& 513 524 & TRIM(tl_multi%t_mpp(ji)%t_proc(1)%t_var(jj)%c_name) … … 541 552 CALL iom_mpp_open(tl_mpp) 542 553 543 544 554 ! get or check depth value 545 555 CALL create_restart_check_depth( tl_mpp, tl_depth ) … … 551 561 CALL iom_mpp_close(tl_mpp) 552 562 553 IF( ANY( tl_mpp%t_dim(1:2)%i_len /=&554 & tl_coord0%t_dim(1:2)%i_len) )THEN563 IF( ANY(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) .OR.& 564 & ALL(il_rho(:)==1) )THEN 555 565 !!! extract value from fine grid 556 566 557 IF( ANY( tl_mpp%t_dim(1:2)%i_len < =&567 IF( ANY( tl_mpp%t_dim(1:2)%i_len < & 558 568 & tl_coord1%t_dim(1:2)%i_len) )THEN 559 CALL logger_fatal("CREATE RESTART: dimension in file "//&569 CALL logger_fatal("CREATE RESTART: dimensions in file "//& 560 570 & TRIM(tl_mpp%c_name)//" smaller than those in fine"//& 561 571 & " grid coordinates.") 562 572 ENDIF 563 573 574 ! use coord0 instead of mpp for restart file case 575 ! (without lon,lat) 576 ll_sameGrid=.FALSE. 577 IF( ALL(tl_mpp%t_dim(1:2)%i_len /= tl_coord0%t_dim(1:2)%i_len) & 578 & )THEN 579 ll_sameGrid=.TRUE. 580 ENDIF 581 564 582 ! compute domain on fine grid 565 il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 ) 583 IF( ll_sameGrid )THEN 584 il_ind(:,:)=grid_get_coarse_index(tl_mpp, tl_coord1 ) 585 ELSE 586 il_ind(:,:)=grid_get_coarse_index(tl_coord0, tl_coord1 ) 587 ENDIF 566 588 567 589 il_imin1=il_ind(1,1) ; il_imax1=il_ind(1,2) … … 569 591 570 592 !- check grid coincidence 571 CALL grid_check_coincidence( tl_mpp, tl_coord1, & 572 & il_imin1, il_imax1, & 573 & il_jmin1, il_jmax1, & 574 & il_rho(:) ) 593 IF( ll_sameGrid )THEN 594 CALL grid_check_coincidence( tl_mpp, tl_coord1, & 595 & il_imin1, il_imax1, & 596 & il_jmin1, il_jmax1, & 597 & il_rho(:) ) 598 ELSE 599 CALL grid_check_coincidence( tl_coord0, tl_coord1, & 600 & il_imin1, il_imax1, & 601 & il_jmin1, il_jmax1, & 602 & il_rho(:) ) 603 ENDIF 575 604 576 605 ! compute domain … … 754 783 755 784 DO ji=1,ip_maxdim 785 756 786 IF( tl_dim(ji)%l_use )THEN 757 787 CALL mpp_move_dim(tl_mppout, tl_dim(ji)) … … 763 793 END SELECT 764 794 ENDIF 795 765 796 ENDDO 766 797 … … 879 910 !> and with dimension of the coordinate file.<br/> 880 911 !> Then the variable array of value is split into equal subdomain. 881 !> Each subdomain is filled with the correspondingvalue of the matrix.912 !> Each subdomain is filled with the associated value of the matrix. 882 913 !> 883 914 !> @author J.Paul … … 1169 1200 & tl_depth%d_value(:,:,:,:) ) )THEN 1170 1201 1171 CALL logger_ fatal("CREATE BOUNDARY: depth value from "//&1172 & TRIM(t l_multi%t_mpp(ji)%c_name)//" not conform "//&1202 CALL logger_warn("CREATE BOUNDARY: depth value from "//& 1203 & TRIM(td_mpp%c_name)//" not conform "//& 1173 1204 & " to those from former file(s).") 1174 1205 … … 1226 1257 IF( tl_date1 - tl_date2 /= 0 )THEN 1227 1258 1228 CALL logger_ fatal("CREATE BOUNDARY: date from "//&1229 & TRIM(t l_multi%t_mpp(ji)%c_name)//" not conform "//&1259 CALL logger_warn("CREATE BOUNDARY: date from "//& 1260 & TRIM(td_mpp%c_name)//" not conform "//& 1230 1261 & " to those from former file(s).") 1231 1262 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/dimension.f90
r5616 r6455 154 154 ! REVISION HISTORY: 155 155 !> @date November, 2013 - Initial Version 156 !> @date Spetember, 2015 157 !> - manage useless (dummy) dimension 156 158 !> 157 159 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 167 169 ! type and variable 168 170 PUBLIC :: TDIM !< dimension structure 171 172 PRIVATE :: cm_dumdim !< dummy dimension array 169 173 170 174 ! function and subroutine … … 182 186 PUBLIC :: dim_get_index !< get dimension index in array of dimension structure 183 187 PUBLIC :: dim_get_id !< get dimension id in array of dimension structure 188 PUBLIC :: dim_get_dummy !< fill dummy dimension array 189 PUBLIC :: dim_is_dummy !< check if dimension is defined as dummy dimension 184 190 185 191 PRIVATE :: dim__reshape_2xyzt_dp ! reshape real(8) 4D array to ('x','y','z','t') … … 209 215 END TYPE 210 216 217 CHARACTER(LEN=lc), DIMENSION(ip_maxdum), SAVE :: cm_dumdim !< dummy dimension 218 211 219 INTERFACE dim_print 212 220 MODULE PROCEDURE dim__print_unit ! print information on one dimension … … 518 526 !> @param[in] ld_uld dimension unlimited 519 527 !> @param[in] cd_sname dimension short name 520 !> @param[in] ld_u lddimension use or not528 !> @param[in] ld_use dimension use or not 521 529 !> @return dimension structure 522 530 !------------------------------------------------------------------- 523 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname, ld_use )531 TYPE(TDIM) FUNCTION dim_init( cd_name, id_len, ld_uld, cd_sname, ld_use ) 524 532 IMPLICIT NONE 525 533 … … 1401 1409 1402 1410 END SUBROUTINE dim__clean_arr 1411 !------------------------------------------------------------------- 1412 !> @brief This subroutine fill dummy dimension array 1413 ! 1414 !> @author J.Paul 1415 !> @date September, 2015 - Initial Version 1416 ! 1417 !> @param[in] cd_dummy dummy configuration file 1418 !------------------------------------------------------------------- 1419 SUBROUTINE dim_get_dummy( cd_dummy ) 1420 IMPLICIT NONE 1421 ! Argument 1422 CHARACTER(LEN=*), INTENT(IN) :: cd_dummy 1423 1424 ! local variable 1425 INTEGER(i4) :: il_fileid 1426 INTEGER(i4) :: il_status 1427 1428 LOGICAL :: ll_exist 1429 1430 ! loop indices 1431 ! namelist 1432 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumvar 1433 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumdim 1434 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumatt 1435 1436 !---------------------------------------------------------------- 1437 NAMELIST /namdum/ & !< dummy namelist 1438 & cn_dumvar, & !< variable name 1439 & cn_dumdim, & !< dimension name 1440 & cn_dumatt !< attribute name 1441 !---------------------------------------------------------------- 1442 1443 ! init 1444 cm_dumdim(:)='' 1445 1446 ! read namelist 1447 INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) 1448 IF( ll_exist )THEN 1449 1450 il_fileid=fct_getunit() 1451 1452 OPEN( il_fileid, FILE=TRIM(cd_dummy), & 1453 & FORM='FORMATTED', & 1454 & ACCESS='SEQUENTIAL', & 1455 & STATUS='OLD', & 1456 & ACTION='READ', & 1457 & IOSTAT=il_status) 1458 CALL fct_err(il_status) 1459 IF( il_status /= 0 )THEN 1460 CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) 1461 ENDIF 1462 1463 READ( il_fileid, NML = namdum ) 1464 cm_dumdim(:)=cn_dumdim(:) 1465 1466 CLOSE( il_fileid ) 1467 1468 ENDIF 1469 1470 END SUBROUTINE dim_get_dummy 1471 !------------------------------------------------------------------- 1472 !> @brief This function check if dimension is defined as dummy dimension 1473 !> in configuraton file 1474 !> 1475 !> @author J.Paul 1476 !> @date September, 2015 - Initial Version 1477 ! 1478 !> @param[in] td_dim dimension structure 1479 !> @return true if dimension is dummy dimension 1480 !------------------------------------------------------------------- 1481 FUNCTION dim_is_dummy(td_dim) 1482 IMPLICIT NONE 1483 1484 ! Argument 1485 TYPE(TDIM), INTENT(IN) :: td_dim 1486 1487 ! function 1488 LOGICAL :: dim_is_dummy 1489 1490 ! loop indices 1491 INTEGER(i4) :: ji 1492 !---------------------------------------------------------------- 1493 1494 dim_is_dummy=.FALSE. 1495 DO ji=1,ip_maxdum 1496 IF( fct_lower(td_dim%c_name) == fct_lower(cm_dumdim(ji)) )THEN 1497 dim_is_dummy=.TRUE. 1498 EXIT 1499 ENDIF 1500 ENDDO 1501 1502 END FUNCTION dim_is_dummy 1403 1503 END MODULE dim 1404 1504 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/docsrc/1_install.md
r5616 r6455 1 # How to Install1 # Download 2 2 3 # Install NEMO4 to install SIREN, you should first installNEMO.5 see [ here](http://www.nemo-ocean.eu/Using-NEMO/User-Guides/Basics/NEMO-Quick-Start-Guide)3 # Download NEMO # 4 to install SIREN, you should first download NEMO. 5 see [NEMO quick start guide](http://www.nemo-ocean.eu/Using-NEMO/User-Guides/Basics/NEMO-Quick-Start-Guide) 6 6 7 # Compile SIREN 7 # Compile SIREN # 8 8 when NEMO is installed, you just have to compile SIREN codes: 9 1. go to ./NEMOGCM/TOOLS 10 2. use maketools <br/> 11 to get help: maketools -h 9 1. go to ./NEMOGCM/TOOLS 10 2. run maketools (ex: ./maketools -n SIREN -m ifort_mpi_beaufix) 12 11 13 # Fortran Compiler 14 SIREN codes were succesfully tested with : 15 - ifort (version 15.0.1) 16 - gfortran (version 4.8.2 20140120) 17 <!-- - pgf95 (version 13.9-0) --> 12 @note to get help on maketools: ./maketools -h 18 13 19 <HR> 20 <b> 21 - @ref index 22 - @ref md_docsrc_3_codingRules 23 - @ref md_docsrc_4_changeLog 24 - @ref todo 25 </b> 14 # Fortran Compiler # 15 SIREN codes were succesfully tested with : 16 - ifort (version 15.0.1) 17 - gfortran (version 4.8.2 20140120) 18 19 <HR> 20 <b> 21 - @ref index 22 - @ref md_docsrc_2_quickstart 23 - @ref md_docsrc_3_support_bug 24 - @ref md_docsrc_4_codingRules 25 - @ref md_docsrc_5_changeLog 26 - @ref todo 27 </b> -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/docsrc/main.dox
r5037 r6455 1 1 /*! 2 @mainpage Main Page 3 @section descr Generic Description 4 SIREN is a software to create regional configuration with 5 [NEMO](http://www.nemo-ocean.eu).<br/> 2 @mainpage About 3 4 SIREN is a software to create regional configuration with [NEMO](http://www.nemo-ocean.eu).<br/> 6 5 Actually SIREN create input files needed for a basic NEMO configuration.<br/> 6 7 SIREN allows you to create your own regional configuration embedded in a wider one.<br/> 8 In order to help you, a set of GLORYS files (global reanalysis on ORCA025 grid), as well as examples 9 of namelists are available in dods repository. 10 11 @note This software was created, and is maintain by the Configuration Manager Working Group, composed 12 of NEMO system team members. 7 13 8 SIREN is composed of a set of 5 Fortran programs : 9 - create_coord.f90 to create fine grid coordinate file from coarse grid coordinate file. 10 - create_bathy.f90 to create fine grid bathymetry file over domain. 11 - merge_bathy.f90 to merge fine grid bathymetry with coarse grid bathymetry at boundaries. 12 - create_restart.f90 to create initial state file from coarse grid restart or standard outputs. 13 - create_boundary.f90 to create boundary condition from coarse grid standard outputs. 14 To know how to install SIREN see @ref md_docsrc_1_install. 14 15 15 To install those programs see @ref md_docsrc_1_install. 16 17 @note SIREN can not: 18 - create global configuration 19 - create configuarion around or close to north pole 20 - change number of vertical level 21 - change grid (horizontal or vertical) 22 23 @section howto How to use 24 @subsection howto_coord to create fine grid coordinate file 25 see create_coord.f90 26 @subsection howto_bathy to create fine grid bathymetry 27 see create_bathy.f90 28 @subsection howto_merge to merge fine grid bathymetry 29 see merge_bathy.f90 30 @subsection howto_restart to create initial state file 31 see create_restart.f90 32 @subsection howto_boundary to create boundary condition 33 see create_boundary.f90 16 You could find a tutorial for a quick start with SIREN in @ref md_docsrc_2_quickstart.<br/> 17 For more information about how to use each component of SIREN 18 - see create_coord.f90 to create fine grid coordinate file 19 - see create_bathy.f90 to create fine grid bathymetry 20 - see merge_bathy.f90 to merge fine grid bathymetry 21 - see create_restart.f90 to create initial state file, or other fields. 22 - see create_boundary.F90 to create boundary condition 34 23 35 24 <HR> 36 25 <b> 37 26 - @ref md_docsrc_1_install 38 - @ref md_docsrc_3_codingRules 39 - @ref md_docsrc_4_changeLog 27 - @ref md_docsrc_2_quickstart 28 - @ref md_docsrc_3_support_bug 29 - @ref md_docsrc_4_codingRules 30 - @ref md_docsrc_5_changeLog 40 31 - @ref todo 41 32 </b> -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/domain.f90
r5616 r6455 1297 1297 !> @date September, 2014 1298 1298 !> - take into account number of ghost cell 1299 !> @date February, 2016 1300 !> - number of extra point is the MAX (not the MIN) of zero and asess value. 1299 1301 ! 1300 1302 !> @param[inout] td_dom domain strcuture … … 1344 1346 td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1) 1345 1347 ELSE ! td_dom%i_imin - il_iext <= td_dom%i_ghost0(jp_I,1)*ip_ghost 1346 td_dom%i_iextra(1) = M IN(0, &1348 td_dom%i_iextra(1) = MAX(0, & 1347 1349 & td_dom%i_imin - & 1348 1350 & td_dom%i_ghost0(jp_I,1)*ip_ghost -1) … … 1356 1358 ELSE ! td_dom%i_imax + il_iext >= & 1357 1359 ! td_dom%t_dim0(1)%i_len - td_dom%i_ghost0(jp_I,2)*ip_ghost 1358 td_dom%i_iextra(2) = M IN(0, &1360 td_dom%i_iextra(2) = MAX( 0, & 1359 1361 & td_dom%t_dim0(1)%i_len - & 1360 1362 & td_dom%i_ghost0(jp_I,2)*ip_ghost - & … … 1364 1366 1365 1367 ELSE ! td_dom%i_ew0 >= 0 1368 1366 1369 ! EW cyclic 1367 1370 IF( td_dom%i_imin - il_iext > 0 )THEN … … 1391 1394 ! nothing to be done 1392 1395 ELSE 1396 1393 1397 IF( td_dom%i_jmin - il_jext > td_dom%i_ghost0(jp_J,1)*ip_ghost )THEN 1394 1398 td_dom%i_jextra(1) = il_jext 1395 1399 td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1) 1396 1400 ELSE ! td_dom%i_jmin - il_jext <= td_dom%i_ghost0(jp_J,1)*ip_ghost 1397 td_dom%i_jextra(1) = M IN(0, &1401 td_dom%i_jextra(1) = MAX( 0, & 1398 1402 & td_dom%i_jmin - & 1399 1403 & td_dom%i_ghost0(jp_J,1)*ip_ghost - 1) … … 1407 1411 ELSE ! td_dom%i_jmax + il_jext >= & 1408 1412 ! td_dom%t_dim0(2)%i_len - td_dom%i_ghost0(jp_J,2)*ip_ghost 1409 td_dom%i_jextra(2) = M IN(0, &1413 td_dom%i_jextra(2) = MAX( 0, & 1410 1414 & td_dom%t_dim0(2)%i_len - & 1411 1415 & td_dom%i_ghost0(jp_J,2)*ip_ghost - & -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/file.f90
r5616 r6455 694 694 !> @date November, 2013 - Initial Version 695 695 !> @date September, 2014 696 !> - add dimension tofile if need be696 !> - add dimension in file if need be 697 697 !> - do not reorder dimension from variable, before put in file 698 !> @date September, 2015 699 !> - check variable dimension expected 698 700 ! 699 701 !> @param[inout] td_file file structure … … 705 707 ! Argument 706 708 TYPE(TFILE), INTENT(INOUT) :: td_file 707 TYPE(TVAR) , INTENT(IN 709 TYPE(TVAR) , INTENT(INOUT) :: td_var 708 710 709 711 ! local variable … … 761 763 IF( file_check_var_dim(td_file, td_var) )THEN 762 764 765 ! check variable dimension expected 766 CALL var_check_dim(td_var) 767 763 768 ! update dimension if need be 764 769 DO ji=1,ip_maxdim … … 1050 1055 ! new number of variable in file 1051 1056 td_file%i_nvar=td_file%i_nvar-1 1052 1053 1057 SELECT CASE(td_var%i_ndim) 1054 1058 CASE(0) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/function.f90
r5608 r6455 363 363 IF( id_status /= 0 )THEN 364 364 !CALL ERRSNS() ! not F95 standard 365 PRINT *, "FORTRAN ERROR "365 PRINT *, "FORTRAN ERROR ",id_status 366 366 !STOP 367 367 ENDIF … … 740 740 ! 741 741 !> @param[in] cd_var character 742 !> @return character is numeric742 !> @return character is real number 743 743 !------------------------------------------------------------------- 744 744 PURE LOGICAL FUNCTION fct_is_real(cd_var) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/global.f90
r5037 r6455 12 12 ! REVISION HISTORY: 13 13 !> @date November, 2013 - Initial Version 14 !> @date September, 2015 15 !> - define fill value for each variable type 14 16 ! 15 17 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 95 97 & 'gauss '/) 96 98 97 REAL(dp) , PARAMETER :: dp_fill=NF90_FILL_DOUBLE !< default fill value 99 REAL(dp) , PARAMETER :: dp_fill_i1=NF90_FILL_BYTE !< byte fill value 100 REAL(dp) , PARAMETER :: dp_fill_i2=NF90_FILL_SHORT !< short fill value 101 REAL(dp) , PARAMETER :: dp_fill_i4=NF90_FILL_INT !< INT fill value 102 REAL(dp) , PARAMETER :: dp_fill_sp=NF90_FILL_FLOAT !< real fill value 103 REAL(dp) , PARAMETER :: dp_fill=NF90_FILL_DOUBLE !< double fill value 98 104 99 105 INTEGER(i4) , PARAMETER :: ip_npoint=4 … … 125 131 INTEGER(i4), PARAMETER :: jp_west =4 126 132 127 133 INTEGER(i4) , PARAMETER :: ip_maxdum = 10 !< maximum dummy variable, dimension, attribute 128 134 129 135 END MODULE global -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/grid.f90
r5616 r6455 80 80 !> point:<br/> 81 81 !> @code 82 !> il_index(:)=grid_get_closest(dd_lon0(:,:), dd_lat0(:,:), dd_lon1, dd_lat1) 82 !> il_index(:)=grid_get_closest(dd_lon0(:,:), dd_lat0(:,:), dd_lon1, dd_lat1 83 !> [,dd_fill] [,cd_pos]) 83 84 !> @endcode 84 85 !> - il_index(:) is coarse grid indices (/ i0, j0 /) … … 87 88 !> - dd_lon1 is fine grid longitude value (real(8)) 88 89 !> - dd_lat1 is fine grid latitude value (real(8)) 90 !> - dd_fill 91 !> - cd_pos 89 92 !> 90 93 !> to compute distance between a point A and grid points:<br/> … … 215 218 !> @date February, 2015 216 219 !> - add function grid_fill_small_msk to fill small domain inside bigger one 220 !> @February, 2016 221 !> - improve way to check coincidence (bug fix) 222 !> - manage grid cases for T,U,V or F point, with even or odd refinment (bug fix) 217 223 ! 218 224 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 664 670 665 671 ! no pivot point found 666 CALL logger_ error("GRID GET PIVOT: something wrong "//&672 CALL logger_warn("GRID GET PIVOT: something wrong "//& 667 673 & "when computing pivot point with variable "//& 668 674 & TRIM(td_var%c_name)) … … 685 691 686 692 IF( grid__get_pivot_var /= -1 )THEN 687 CALL logger_ warn("GRID GET PIVOT: variable "//&693 CALL logger_info("GRID GET PIVOT: variable "//& 688 694 & TRIM(td_var%c_name)//" seems to be on grid point "//& 689 695 & TRIM(cp_grid_point(jj)) ) … … 1335 1341 il_dim(:)=td_var%t_dim(:)%i_len 1336 1342 1337 CALL logger_ info("GRID GET PERIO: use varibale "//TRIM(td_var%c_name))1338 CALL logger_ info("GRID GET PERIO: fill value "//TRIM(fct_str(td_var%d_fill)))1339 CALL logger_ info("GRID GET PERIO: fillvalue "//TRIM(fct_str(td_var%d_value(1,1,1,1))))1343 CALL logger_debug("GRID GET PERIO: use varibale "//TRIM(td_var%c_name)) 1344 CALL logger_debug("GRID GET PERIO: fill value "//TRIM(fct_str(td_var%d_fill))) 1345 CALL logger_debug("GRID GET PERIO: first value "//TRIM(fct_str(td_var%d_value(1,1,1,1)))) 1340 1346 1341 1347 IF(ALL(td_var%d_value( 1 , : ,1,1)/=td_var%d_fill).AND.& … … 1344 1350 & ALL(td_var%d_value( : ,il_dim(2),1,1)/=td_var%d_fill))THEN 1345 1351 ! no boundary closed 1346 CALL logger_ warn("GRID GET PERIO: can't determined periodicity. "//&1352 CALL logger_error("GRID GET PERIO: can't determined periodicity. "//& 1347 1353 & "there is no boundary closed for variable "//& 1348 1354 & TRIM(td_var%c_name) ) 1355 ! check pivot 1356 SELECT CASE(id_pivot) 1357 CASE(0) 1358 ! F pivot 1359 CALL logger_warn("GRID GET PERIO: assume domain is global") 1360 grid__get_perio_var=6 1361 CASE(1) 1362 ! T pivot 1363 CALL logger_warn("GRID GET PERIO: assume domain is global") 1364 grid__get_perio_var=4 1365 END SELECT 1349 1366 ELSE 1350 1367 ! check periodicity … … 2287 2304 & il_rho(:), cl_point ) 2288 2305 2289 2290 2306 CALL var_clean(tl_lon1) 2291 2307 CALL var_clean(tl_lat1) … … 2463 2479 !> - check grid point 2464 2480 !> - take into account EW overlap 2481 !> @date February, 2016 2482 !> - use delta (lon or lat) 2483 !> - manage cases for T,U,V or F point, with even or odd refinment 2465 2484 !> 2466 2485 !> @param[in] td_lon0 coarse grid longitude … … 2490 2509 2491 2510 ! local variable 2492 REAL(dp) :: dl_lon1_ll 2493 REAL(dp) :: dl_lon1_ul 2494 REAL(dp) :: dl_lon1_lr 2495 REAL(dp) :: dl_lon1_ur 2496 2497 REAL(dp) :: dl_lat1_ll 2498 REAL(dp) :: dl_lat1_ul 2499 REAL(dp) :: dl_lat1_lr 2500 REAL(dp) :: dl_lat1_ur 2511 CHARACTER(LEN= 1) :: cl_point0 2512 CHARACTER(LEN= 1) :: cl_point1 2513 2514 LOGICAL , DIMENSION(2) :: ll_even 2515 2516 REAL(dp) :: dl_lon1 2517 REAL(dp) :: dl_dlon 2518 REAL(dp) :: dl_lat1 2519 REAL(dp) :: dl_dlat 2520 2521 INTEGER(i4) :: il_ew0 2522 INTEGER(i4) :: il_imin0 2523 INTEGER(i4) :: il_imax0 2524 INTEGER(i4) :: il_jmin0 2525 INTEGER(i4) :: il_jmax0 2526 2527 INTEGER(i4) :: il_ew1 2528 INTEGER(i4) :: il_imin1 2529 INTEGER(i4) :: il_imax1 2530 INTEGER(i4) :: il_jmin1 2531 INTEGER(i4) :: il_jmax1 2532 2533 INTEGER(i4) :: il_imin 2534 INTEGER(i4) :: il_imax 2535 INTEGER(i4) :: il_jmin 2536 INTEGER(i4) :: il_jmax 2501 2537 2502 2538 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_rho 2503 2539 2504 INTEGER(i4), DIMENSION(2) :: il_ill 2505 INTEGER(i4), DIMENSION(2) :: il_ilr 2506 INTEGER(i4), DIMENSION(2) :: il_iul 2507 INTEGER(i4), DIMENSION(2) :: il_iur 2508 2509 INTEGER(i4) :: il_ew0 2510 INTEGER(i4) :: il_imin0 2511 INTEGER(i4) :: il_imax0 2512 INTEGER(i4) :: il_jmin0 2513 INTEGER(i4) :: il_jmax0 2514 2515 INTEGER(i4) :: il_ew1 2516 INTEGER(i4) :: il_imin1 2517 INTEGER(i4) :: il_imax1 2518 INTEGER(i4) :: il_jmin1 2519 INTEGER(i4) :: il_jmax1 2520 2521 INTEGER(i4) :: il_imin 2522 INTEGER(i4) :: il_imax 2523 INTEGER(i4) :: il_jmin 2524 INTEGER(i4) :: il_jmax 2525 2526 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2527 INTEGER(i4), DIMENSION(2,2) :: il_yghost0 2528 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2529 INTEGER(i4), DIMENSION(2,2) :: il_yghost1 2530 2531 TYPE(TVAR) :: tl_lon0 2532 TYPE(TVAR) :: tl_lat0 2533 TYPE(TVAR) :: tl_lon1 2534 TYPE(TVAR) :: tl_lat1 2535 2536 CHARACTER(LEN= 1) :: cl_point0 2537 CHARACTER(LEN= 1) :: cl_point1 2538 2540 INTEGER(i4), DIMENSION(2) :: il_ill 2541 INTEGER(i4), DIMENSION(2) :: il_ilr 2542 INTEGER(i4), DIMENSION(2) :: il_iul 2543 INTEGER(i4), DIMENSION(2) :: il_iur 2544 2545 INTEGER(i4), DIMENSION(2,2) :: il_xghost0 2546 INTEGER(i4), DIMENSION(2,2) :: il_yghost0 2547 INTEGER(i4), DIMENSION(2,2) :: il_xghost1 2548 INTEGER(i4), DIMENSION(2,2) :: il_yghost1 2549 2550 TYPE(TVAR) :: tl_lon0 2551 TYPE(TVAR) :: tl_lat0 2552 TYPE(TVAR) :: tl_lon1 2553 TYPE(TVAR) :: tl_lat1 2554 2539 2555 ! loop indices 2540 INTEGER(i4) :: ji2541 INTEGER(i4) :: jj2542 2556 !---------------------------------------------------------------- 2543 2557 ! init … … 2547 2561 il_rho(:)=1 2548 2562 IF( PRESENT(id_rho) ) il_rho(:)=id_rho(:) 2563 2564 ll_even(:)=(/ (MOD(id_rho(jp_I),2)==0), (MOD(id_rho(jp_J),2)==0) /) 2549 2565 2550 2566 cl_point0='T' … … 2645 2661 ! get indices for each corner 2646 2662 !1- search lower left corner indices 2647 dl_lon1_ll=tl_lon1%d_value( il_imin1, il_jmin1, 1, 1 ) 2648 dl_lat1_ll=tl_lat1%d_value( il_imin1, il_jmin1, 1, 1 ) 2649 2650 IF( dl_lon1_ll == tl_lon1%d_fill .OR. & 2651 & dl_lat1_ll == tl_lat1%d_fill )THEN 2652 CALL logger_debug("GRID GET COARSE INDEX: lon "//& 2653 & TRIM(fct_str(dl_lon1_ll))//" "//& 2654 & TRIM(fct_str(tl_lon1%d_fill)) ) 2655 CALL logger_debug("GRID GET COARSE INDEX: lat "//& 2656 & TRIM(fct_str(dl_lat1_ll))//" "//& 2657 & TRIM(fct_str(tl_lat1%d_fill)) ) 2663 dl_lon1=tl_lon1%d_value( il_imin1, il_jmin1, 1, 1 ) 2664 dl_lat1=tl_lat1%d_value( il_imin1, il_jmin1, 1, 1 ) 2665 2666 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2667 & dl_lat1 == tl_lat1%d_fill )THEN 2658 2668 CALL logger_error("GRID GET COARSE INDEX: lower left corner "//& 2659 2669 & "point is FillValue. remove ghost cell "//& 2660 2670 & "before running grid_get_coarse_index.") 2661 2671 ENDIF 2672 2673 !!!!! i-direction !!!!! 2674 IF( ll_even(jp_I) )THEN 2675 ! even 2676 SELECT CASE(TRIM(cl_point1)) 2677 CASE('F','U') 2678 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmin1,1,1) - & 2679 & tl_lon1%d_value(il_imin1 ,il_jmin1,1,1) ) / & 2680 & 2. 2681 CASE DEFAULT 2682 dl_dlon=0 2683 END SELECT 2684 ELSE 2685 ! odd 2686 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmin1,1,1) - & 2687 & tl_lon1%d_value(il_imin1 ,il_jmin1,1,1) ) / & 2688 & 2. 2689 ENDIF 2690 2691 !!!!! j-direction !!!!! 2692 IF( ll_even(jp_J) )THEN 2693 ! even 2694 SELECT CASE(TRIM(cl_point1)) 2695 CASE('F','V') 2696 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmin1+1,1,1) - & 2697 & tl_lat1%d_value(il_imin1,il_jmin1 ,1,1) ) / & 2698 & 2. 2699 CASE DEFAULT 2700 dl_dlat=0 2701 END SELECT 2702 ELSE 2703 ! odd 2704 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmin1+1,1,1) - & 2705 & tl_lat1%d_value(il_imin1,il_jmin1 ,1,1) ) / & 2706 & 2. 2707 ENDIF 2708 2709 dl_lon1 = dl_lon1 + dl_dlon 2710 dl_lat1 = dl_lat1 + dl_dlat 2711 2662 2712 ! look for closest point on coarse grid 2663 2713 il_ill(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2667 2717 & il_jmin0:il_jmax0, & 2668 2718 & 1,1), & 2669 & dl_lon1_ll, dl_lat1_ll ) 2670 2671 ! coarse grid point should be south west of fine grid domain 2672 ji = il_ill(1) 2673 jj = il_ill(2) 2674 2675 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ll) > dp_delta )THEN 2676 IF(tl_lon0%d_value(ji,jj,1,1) > dl_lon1_ll )THEN 2677 il_ill(1)=il_ill(1)-1 2678 IF( il_ill(1) <= 0 )THEN 2679 IF( tl_lon0%i_ew >= 0 )THEN 2680 il_ill(1)=tl_lon0%t_dim(jp_I)%i_len-tl_lon0%i_ew 2681 ELSE 2682 CALL logger_error("GRID GET COARSE INDEX: error "//& 2683 & "computing lower left corner "//& 2684 & "index for longitude") 2685 ENDIF 2686 ENDIF 2687 ENDIF 2688 ENDIF 2689 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ll) > dp_delta )THEN 2690 IF(tl_lat0%d_value(ji,jj,1,1) > dl_lat1_ll )THEN 2691 il_ill(2)=il_ill(2)-1 2692 IF( il_ill(2)-1 <= 0 )THEN 2693 CALL logger_error("GRID GET COARSE INDEX: error "//& 2694 & "computing lower left corner "//& 2695 & "index for latitude") 2696 ENDIF 2697 ENDIF 2698 ENDIF 2719 & dl_lon1, dl_lat1, 'll' ) 2720 2699 2721 2700 2722 !2- search upper left corner indices 2701 dl_lon1 _ul=tl_lon1%d_value( il_imin1, il_jmax1, 1, 1 )2702 dl_lat1 _ul=tl_lat1%d_value( il_imin1, il_jmax1, 1, 1 )2703 2704 IF( dl_lon1 _ul== tl_lon1%d_fill .OR. &2705 & dl_lat1 _ul== tl_lat1%d_fill )THEN2723 dl_lon1=tl_lon1%d_value( il_imin1, il_jmax1, 1, 1 ) 2724 dl_lat1=tl_lat1%d_value( il_imin1, il_jmax1, 1, 1 ) 2725 2726 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2727 & dl_lat1 == tl_lat1%d_fill )THEN 2706 2728 CALL logger_error("GRID GET COARSE INDEX: upper left corner "//& 2707 2729 & "point is FillValue. remove ghost cell "//& 2708 2730 & "running grid_get_coarse_index.") 2709 2731 ENDIF 2732 2733 !!!!! i-direction !!!!! 2734 IF( ll_even(jp_I) )THEN 2735 ! even 2736 SELECT CASE(TRIM(cl_point1)) 2737 CASE('F','U') 2738 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmax1,1,1) - & 2739 & tl_lon1%d_value(il_imin1 ,il_jmax1,1,1) ) / & 2740 & 2. 2741 CASE DEFAULT 2742 dl_dlon=0 2743 END SELECT 2744 ELSE 2745 ! odd 2746 dl_dlon= ( tl_lon1%d_value(il_imin1+1,il_jmax1,1,1) - & 2747 & tl_lon1%d_value(il_imin1 ,il_jmax1,1,1) ) / & 2748 & 2. 2749 ENDIF 2750 2751 !!!!! j-direction !!!!! 2752 IF( ll_even(jp_J) )THEN 2753 ! even 2754 SELECT CASE(TRIM(cl_point1)) 2755 CASE('F','V') 2756 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmax1 ,1,1) - & 2757 & tl_lat1%d_value(il_imin1,il_jmax1-1,1,1) ) / & 2758 & 2. 2759 CASE DEFAULT 2760 dl_dlat=0 2761 END SELECT 2762 ELSE 2763 ! odd 2764 dl_dlat= ( tl_lat1%d_value(il_imin1,il_jmax1 ,1,1) - & 2765 & tl_lat1%d_value(il_imin1,il_jmax1-1,1,1) ) / & 2766 & 2. 2767 ENDIF 2768 2769 dl_lon1 = dl_lon1 + dl_dlon 2770 dl_lat1 = dl_lat1 - dl_dlat 2771 2710 2772 ! look for closest point on coarse grid 2711 2773 il_iul(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2715 2777 & il_jmin0:il_jmax0, & 2716 2778 & 1,1), & 2717 & dl_lon1_ul, dl_lat1_ul ) 2718 2719 ! coarse grid point should be north west of fine grid domain 2720 ji = il_iul(1) 2721 jj = il_iul(2) 2722 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ul) > dp_delta )THEN 2723 IF(tl_lon0%d_value(ji,jj,1,1) > dl_lon1_ul )THEN 2724 il_iul(1)=il_iul(1)-1 2725 IF( il_iul(1) <= 0 )THEN 2726 IF( tl_lon0%i_ew >= 0 )THEN 2727 il_iul(1)=tl_lon0%t_dim(jp_I)%i_len-tl_lon0%i_ew 2728 ELSE 2729 CALL logger_error("GRID GET COARSE INDEX: error "//& 2730 & "computing upper left corner "//& 2731 & "index for longitude") 2732 ENDIF 2733 ENDIF 2734 ENDIF 2735 ENDIF 2736 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ul) > dp_delta )THEN 2737 IF(tl_lat0%d_value(ji,jj,1,1) < dl_lat1_ul )THEN 2738 il_iul(2)=il_iul(2)+1 2739 IF( il_ill(2) > tl_lat0%t_dim(jp_J)%i_len )THEN 2740 CALL logger_error("GRID GET COARSE INDEX: error "//& 2741 & "computing upper left corner "//& 2742 & "index for latitude") 2743 ENDIF 2744 ENDIF 2745 ENDIF 2779 & dl_lon1, dl_lat1, 'ul' ) 2746 2780 2747 2781 !3- search lower right corner indices 2748 dl_lon1 _lr=tl_lon1%d_value( il_imax1, il_jmin1, 1, 1 )2749 dl_lat1 _lr=tl_lat1%d_value( il_imax1, il_jmin1, 1, 1 )2750 2751 IF( dl_lon1 _lr== tl_lon1%d_fill .OR. &2752 & dl_lat1 _lr== tl_lat1%d_fill )THEN2782 dl_lon1=tl_lon1%d_value( il_imax1, il_jmin1, 1, 1 ) 2783 dl_lat1=tl_lat1%d_value( il_imax1, il_jmin1, 1, 1 ) 2784 2785 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2786 & dl_lat1 == tl_lat1%d_fill )THEN 2753 2787 CALL logger_error("GRID GET COARSE INDEX: lower right corner "//& 2754 2788 & "point is FillValue. remove ghost cell "//& 2755 2789 & "running grid_get_coarse_index.") 2756 2790 ENDIF 2791 2792 !!!!! i-direction !!!!! 2793 IF( ll_even(jp_I) )THEN 2794 ! even 2795 SELECT CASE(TRIM(cl_point1)) 2796 CASE('F','U') 2797 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmin1,1,1) - & 2798 & tl_lon1%d_value(il_imax1-1,il_jmin1,1,1) ) / & 2799 & 2. 2800 CASE DEFAULT 2801 dl_dlon=0 2802 END SELECT 2803 ELSE 2804 ! odd 2805 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmin1,1,1) - & 2806 & tl_lon1%d_value(il_imax1-1,il_jmin1,1,1) ) / & 2807 & 2. 2808 ENDIF 2809 2810 !!!!! j-direction !!!!! 2811 IF( ll_even(jp_J) )THEN 2812 ! even 2813 SELECT CASE(TRIM(cl_point1)) 2814 CASE('F','V') 2815 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmin1+1,1,1) - & 2816 & tl_lat1%d_value(il_imax1,il_jmin1 ,1,1) ) / & 2817 & 2. 2818 CASE DEFAULT 2819 dl_dlat=0 2820 END SELECT 2821 ELSE 2822 ! odd 2823 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmin1+1,1,1) - & 2824 & tl_lat1%d_value(il_imax1,il_jmin1 ,1,1) ) / & 2825 & 2. 2826 ENDIF 2827 2828 dl_lon1 = dl_lon1 - dl_dlon 2829 dl_lat1 = dl_lat1 + dl_dlat 2830 2757 2831 ! look for closest point on coarse grid 2758 2832 il_ilr(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2762 2836 & il_jmin0:il_jmax0, & 2763 2837 & 1,1), & 2764 & dl_lon1_lr, dl_lat1_lr ) 2765 2766 ! coarse grid point should be south east of fine grid domain 2767 ji = il_ilr(1) 2768 jj = il_ilr(2) 2769 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_lr) > dp_delta )THEN 2770 IF( tl_lon0%d_value(ji,jj,1,1) < dl_lon1_lr )THEN 2771 il_ilr(1)=il_ilr(1)+1 2772 IF( il_ilr(1) > tl_lon0%t_dim(jp_I)%i_len )THEN 2773 IF( tl_lon0%i_ew >= 0 )THEN 2774 il_ilr(1)=tl_lon0%i_ew+1 2775 ELSE 2776 CALL logger_error("GRID GET COARSE INDEX: error "//& 2777 & "computing lower right corner "//& 2778 & "index for longitude") 2779 ENDIF 2780 ENDIF 2781 ENDIF 2782 ENDIF 2783 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_lr) > dp_delta )THEN 2784 IF( tl_lat0%d_value(ji,jj,1,1) > dl_lat1_lr )THEN 2785 il_ilr(2)=il_ilr(2)-1 2786 IF( il_ilr(2) <= 0 )THEN 2787 CALL logger_error("GRID GET COARSE INDEX: error "//& 2788 & "computing lower right corner "//& 2789 & "index for latitude") 2790 ENDIF 2791 ENDIF 2792 ENDIF 2838 & dl_lon1, dl_lat1, 'lr' ) 2793 2839 2794 2840 !4- search upper right corner indices 2795 dl_lon1 _ur=tl_lon1%d_value( il_imax1, il_jmax1, 1, 1 )2796 dl_lat1 _ur=tl_lat1%d_value( il_imax1, il_jmax1, 1, 1 )2797 2798 IF( dl_lon1 _ur== tl_lon1%d_fill .OR. &2799 & dl_lat1 _ur== tl_lat1%d_fill )THEN2841 dl_lon1=tl_lon1%d_value( il_imax1, il_jmax1, 1, 1 ) 2842 dl_lat1=tl_lat1%d_value( il_imax1, il_jmax1, 1, 1 ) 2843 2844 IF( dl_lon1 == tl_lon1%d_fill .OR. & 2845 & dl_lat1 == tl_lat1%d_fill )THEN 2800 2846 CALL logger_error("GRID GET COARSE INDEX: upper right corner "//& 2801 2847 & "point is FillValue. remove ghost cell "//& 2802 & " running grid_get_coarse_index.")2848 & "before running grid_get_coarse_index.") 2803 2849 ENDIF 2850 2851 !!!!! i-direction !!!!! 2852 IF( ll_even(jp_I) )THEN 2853 ! even 2854 SELECT CASE(TRIM(cl_point1)) 2855 CASE('F','U') 2856 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmax1,1,1) - & 2857 & tl_lon1%d_value(il_imax1-1,il_jmax1,1,1) ) / & 2858 & 2. 2859 CASE DEFAULT 2860 dl_dlon=0 2861 END SELECT 2862 ELSE 2863 ! odd 2864 dl_dlon= ( tl_lon1%d_value(il_imax1 ,il_jmax1,1,1) - & 2865 & tl_lon1%d_value(il_imax1-1,il_jmax1,1,1) ) / & 2866 & 2. 2867 ENDIF 2868 2869 !!!!! j-direction !!!!! 2870 IF( ll_even(jp_J) )THEN 2871 ! even 2872 SELECT CASE(TRIM(cl_point1)) 2873 CASE('F','V') 2874 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmax1 ,1,1) - & 2875 & tl_lat1%d_value(il_imax1,il_jmax1-1,1,1) ) / & 2876 & 2. 2877 CASE DEFAULT 2878 dl_dlat=0 2879 END SELECT 2880 ELSE 2881 ! odd 2882 dl_dlat= ( tl_lat1%d_value(il_imax1,il_jmax1 ,1,1) - & 2883 & tl_lat1%d_value(il_imax1,il_jmax1-1,1,1) ) / & 2884 & 2. 2885 ENDIF 2886 2887 dl_lon1 = dl_lon1 - dl_dlon 2888 dl_lat1 = dl_lat1 - dl_dlat 2889 2804 2890 ! look for closest point on coarse grid 2805 2891 il_iur(:)= grid_get_closest(tl_lon0%d_value(il_imin0:il_imax0, & … … 2809 2895 & il_jmin0:il_jmax0, & 2810 2896 & 1,1), & 2811 & dl_lon1_ur, dl_lat1_ur ) 2812 2813 ! coarse grid point should be north east fine grid domain 2814 ji = il_iur(1) 2815 jj = il_iur(2) 2816 IF( ABS(tl_lon0%d_value(ji,jj,1,1)-dl_lon1_ur) > dp_delta )THEN 2817 IF( tl_lon0%d_value(ji,jj,1,1) < dl_lon1_ur )THEN 2818 il_iur(1)=il_iur(1)+1 2819 IF( il_iur(1) > tl_lon0%t_dim(jp_I)%i_len )THEN 2820 IF( tl_lon0%i_ew >= 0 )THEN 2821 il_iur(1)=tl_lon0%i_ew+1 2822 ELSE 2823 CALL logger_error("GRID GET COARSE INDEX: error "//& 2824 & "computing upper right corner "//& 2825 & "index for longitude") 2826 ENDIF 2827 ENDIF 2828 ENDIF 2829 ENDIF 2830 IF( ABS(tl_lat0%d_value(ji,jj,1,1)-dl_lat1_ur) > dp_delta )THEN 2831 IF( tl_lat0%d_value(ji,jj,1,1) < dl_lat1_ur )THEN 2832 il_iur(2)=il_iur(2)+1 2833 IF( il_iur(2) > tl_lat0%t_dim(jp_J)%i_len )THEN 2834 CALL logger_error("GRID GET COARSE INDEX: error "//& 2835 & "computing upper right corner "//& 2836 & "index for latitude") 2837 ENDIF 2838 ENDIF 2839 ENDIF 2897 & dl_lon1, dl_lat1, 'ur' ) 2840 2898 2841 2899 ! coarse grid indices … … 2943 3001 END FUNCTION grid_is_global 2944 3002 !------------------------------------------------------------------- 2945 !> @brief This function return coarsegrid indices of the closest point2946 !> from fine gridpoint (lon1,lat1)3003 !> @brief This function return grid indices of the closest point 3004 !> from point (lon1,lat1) 2947 3005 !> 2948 3006 !> @details … … 2951 3009 !> of longitude and latitude, before running this function 2952 3010 !> 3011 !> if you add cd_pos argument, you could choice to return closest point at 3012 !> - lower left (ll) of the point 3013 !> - lower right (lr) of the point 3014 !> - upper left (ul) of the point 3015 !> - upper right (ur) of the point 3016 !> - lower (lo) of the point 3017 !> - upper (up) of the point 3018 !> - left (le) of the point 3019 !> - right (ri) of the point 3020 !> 2953 3021 !> @author J.Paul 2954 3022 !> @date November, 2013 - Initial Version 2955 !> @date February, 2015 - change dichotomy method to manage ORCA grid 3023 !> @date February, 2015 3024 !> - change dichotomy method to manage ORCA grid 3025 !> @date February, 2016 3026 !> - add optional use of relative position 2956 3027 ! 2957 3028 !> @param[in] dd_lon0 coarse grid array of longitude … … 2959 3030 !> @param[in] dd_lon1 fine grid longitude 2960 3031 !> @param[in] dd_lat1 fine grid latitude 3032 !> @param[in] cd_pos relative position of grid point from point 2961 3033 !> @param[in] dd_fill fill value 2962 3034 !> @return coarse grid indices of closest point of fine grid point 2963 3035 !------------------------------------------------------------------- 2964 FUNCTION grid_get_closest( dd_lon0, dd_lat0, dd_lon1, dd_lat1, dd_fill )3036 FUNCTION grid_get_closest( dd_lon0, dd_lat0, dd_lon1, dd_lat1, cd_pos, dd_fill ) 2965 3037 IMPLICIT NONE 2966 3038 ! Argument … … 2969 3041 REAL(dp), INTENT(IN) :: dd_lon1 2970 3042 REAL(dp), INTENT(IN) :: dd_lat1 3043 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_pos 2971 3044 REAL(dp), INTENT(IN), OPTIONAL :: dd_fill 2972 3045 … … 3147 3220 & dl_lon1, dd_lat1 ) 3148 3221 3222 IF( PRESENT(cd_pos) )THEN 3223 ! 3224 SELECT CASE(TRIM(cd_pos)) 3225 CASE('le') 3226 WHERE( dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) 3227 dl_dist(:,:)=NF90_FILL_DOUBLE 3228 END WHERE 3229 CASE('ri') 3230 WHERE( dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) 3231 dl_dist(:,:)=NF90_FILL_DOUBLE 3232 END WHERE 3233 CASE('up') 3234 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 ) 3235 dl_dist(:,:)=NF90_FILL_DOUBLE 3236 END WHERE 3237 CASE('lo') 3238 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 ) 3239 dl_dist(:,:)=NF90_FILL_DOUBLE 3240 END WHERE 3241 CASE('ll') 3242 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 .OR. & 3243 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) 3244 dl_dist(:,:)=NF90_FILL_DOUBLE 3245 END WHERE 3246 CASE('lr') 3247 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 .OR. & 3248 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) > dd_lat1 ) 3249 dl_dist(:,:)=NF90_FILL_DOUBLE 3250 END WHERE 3251 CASE('ul') 3252 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) > dl_lon1 .OR. & 3253 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) 3254 dl_dist(:,:)=NF90_FILL_DOUBLE 3255 END WHERE 3256 CASE('ur') 3257 WHERE( dl_lon0(il_iinf:il_isup,il_jinf:il_jsup) < dl_lon1 .OR. & 3258 & dd_lat0(il_iinf:il_isup,il_jinf:il_jsup) < dd_lat1 ) 3259 dl_dist(:,:)=NF90_FILL_DOUBLE 3260 END WHERE 3261 END SELECT 3262 ENDIF 3149 3263 grid_get_closest(:)=MINLOC(dl_dist(:,:),dl_dist(:,:)/=NF90_FILL_DOUBLE) 3150 3264 … … 3443 3557 & il_imax0, il_jmax0, & 3444 3558 & dl_lon1(:,:), dl_lat1(:,:),& 3445 & id_rho(:) )3559 & id_rho(:), cl_point ) 3446 3560 3447 3561 DEALLOCATE(dl_lon0, dl_lat0) … … 3588 3702 & id_imax0, id_jmax0, & 3589 3703 & dl_lon1(:,:), dl_lat1(:,:),& 3590 & id_rho(:) )3704 & id_rho(:), cl_point ) 3591 3705 3592 3706 DEALLOCATE(dl_lon1, dl_lat1) … … 3668 3782 ! init 3669 3783 grid__get_fine_offset_fc(:,:)=-1 3670 3671 3784 ALLOCATE(il_rho(ip_maxdim)) 3672 3785 il_rho(:)=1 … … 3690 3803 CALL iom_mpp_open(tl_coord0) 3691 3804 3692 ! read coarse longitu e and latitude3805 ! read coarse longitude and latitude 3693 3806 WRITE(cl_name,*) 'longitude_'//TRIM(cl_point) 3694 3807 il_ind=var_get_id(tl_coord0%t_proc(1)%t_var(:), cl_name) … … 3710 3823 ENDIF 3711 3824 tl_lat0=iom_mpp_read_var(tl_coord0, TRIM(cl_name)) 3712 3825 3713 3826 ! close mpp files 3714 3827 CALL iom_mpp_close(tl_coord0) … … 3716 3829 CALL grid_del_ghost(tl_lon0, il_xghost0(:,:)) 3717 3830 CALL grid_del_ghost(tl_lat0, il_xghost0(:,:)) 3831 3718 3832 3719 3833 ALLOCATE(dl_lon0(tl_lon0%t_dim(jp_I)%i_len, & … … 3738 3852 il_jmax0=id_jmax0-il_xghost0(jp_J,1) 3739 3853 3740 3741 3854 !3- compute 3742 3855 grid__get_fine_offset_fc(:,:)=grid_get_fine_offset(& … … 3745 3858 & il_imax0, il_jmax0, & 3746 3859 & dd_lon1(:,:), dd_lat1(:,:),& 3747 & id_rho(:) )3860 & id_rho(:), cl_point ) 3748 3861 3749 3862 DEALLOCATE(dl_lon0, dl_lat0) … … 3767 3880 !> @date May, 2015 3768 3881 !> - improve way to find offset 3882 !> @date July, 2015 3883 !> - manage case close to greenwich meridian 3884 !> @date February, 2016 3885 !> - use grid_get_closest to assess offset 3886 !> - use delta (lon or lat) 3887 !> - manage cases for T,U,V or F point, with even or odd refinment 3888 !> - check lower left(upper right) fine grid point inside lower left(upper 3889 !> right) coarse grid cell. 3890 !> 3891 !> @todo check case close from North fold. 3769 3892 !> 3770 3893 !> @param[in] dd_lon0 coarse grid longitude array … … 3777 3900 !> @param[in] dd_lat1 fine grid latitude array 3778 3901 !> @param[in] id_rho array of refinement factor 3902 !> @param[in] cd_point Arakawa grid point 3779 3903 !> @return offset array (/ (/i_offset_left,i_offset_right/),(/j_offset_lower,j_offset_upper/) /) 3780 3904 !------------------------------------------------------------------- 3781 3905 FUNCTION grid__get_fine_offset_cc( dd_lon0, dd_lat0, & 3782 3906 & id_imin0, id_jmin0, id_imax0, id_jmax0, & 3783 & dd_lon1, dd_lat1, id_rho )3907 & dd_lon1, dd_lat1, id_rho, cd_point ) 3784 3908 IMPLICIT NONE 3785 3909 ! Argument 3786 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon0 3787 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat0 3788 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon1 3789 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat1 3790 3791 INTEGER(i4), INTENT(IN) :: id_imin0 3792 INTEGER(i4), INTENT(IN) :: id_jmin0 3793 INTEGER(i4), INTENT(IN) :: id_imax0 3794 INTEGER(i4), INTENT(IN) :: id_jmax0 3795 3796 INTEGER(i4), DIMENSION(:) , INTENT(IN) :: id_rho 3910 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon0 3911 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat0 3912 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lon1 3913 REAL(dp) , DIMENSION(:,:), INTENT(IN) :: dd_lat1 3914 3915 INTEGER(i4) , INTENT(IN) :: id_imin0 3916 INTEGER(i4) , INTENT(IN) :: id_jmin0 3917 INTEGER(i4) , INTENT(IN) :: id_imax0 3918 INTEGER(i4) , INTENT(IN) :: id_jmax0 3919 3920 INTEGER(i4) , DIMENSION(:) , INTENT(IN) :: id_rho 3921 CHARACTER(LEN=*) , INTENT(IN), OPTIONAL :: cd_point 3797 3922 3798 3923 ! function … … 3800 3925 3801 3926 ! local variable 3927 CHARACTER(LEN= 1) :: cl_point 3928 3929 INTEGER(i4) :: i1 3930 INTEGER(i4) :: i2 3931 INTEGER(i4) :: j1 3932 INTEGER(i4) :: j2 3933 3802 3934 INTEGER(i4), DIMENSION(2) :: il_shape0 3803 3935 INTEGER(i4), DIMENSION(2) :: il_shape1 3804 3936 3937 INTEGER(i4), DIMENSION(2) :: il_ind 3938 3805 3939 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon0 3806 3940 REAL(dp) , DIMENSION(:,:), ALLOCATABLE :: dl_lon1 3807 3941 3808 LOGICAL :: ll_ii 3809 LOGICAL :: ll_ij 3942 REAL(dp) :: dl_lonmax0 3943 REAL(dp) :: dl_latmax0 3944 REAL(dp) :: dl_lonmin0 3945 REAL(dp) :: dl_latmin0 3946 3947 REAL(dp) :: dl_lon0F 3948 REAL(dp) :: dl_lat0F 3949 REAL(dp) :: dl_dlon 3950 REAL(dp) :: dl_dlat 3951 3952 LOGICAL , DIMENSION(2) :: ll_even 3953 LOGICAL :: ll_greenwich 3810 3954 3811 3955 ! loop indices 3812 INTEGER(i4) :: ji3813 INTEGER(i4) :: jj3814 3815 3956 INTEGER(i4) :: ii 3816 3957 INTEGER(i4) :: ij … … 3824 3965 CALL logger_fatal("GRID GET FINE OFFSET: dimension of fine "//& 3825 3966 & "longitude and latitude differ") 3826 ENDIF 3967 ENDIF 3968 3969 ll_even(:)=(/ (MOD(id_rho(jp_I),2)==0), (MOD(id_rho(jp_J),2)==0) /) 3970 3971 cl_point='T' 3972 IF( PRESENT(cd_point) ) cl_point=TRIM(fct_upper(cd_point)) 3827 3973 3828 3974 il_shape0(:)=SHAPE(dd_lon0(:,:)) 3829 3975 ALLOCATE( dl_lon0(il_shape0(1),il_shape0(2)) ) 3830 3976 3977 il_shape1(:)=SHAPE(dd_lon1(:,:)) 3978 ALLOCATE( dl_lon1(il_shape1(1),il_shape1(2)) ) 3979 3831 3980 dl_lon0(:,:)=dd_lon0(:,:) 3832 3981 WHERE( dd_lon0(:,:) < 0 ) dl_lon0(:,:)=dd_lon0(:,:)+360. 3833 3982 3834 il_shape1(:)=SHAPE(dd_lon1(:,:))3835 ALLOCATE( dl_lon1(il_shape1(1),il_shape1(2)) )3836 3837 3983 dl_lon1(:,:)=dd_lon1(:,:) 3838 WHERE( dd_lon1(:,:) < 0 ) dl_lon1(:,:)=dd_lon1(:,:)+360. 3984 WHERE( dd_lon1(:,:) < 0 ) dl_lon1(:,:)=dd_lon1(:,:)+360. 3839 3985 3840 3986 ! init 3841 3987 grid__get_fine_offset_cc(:,:)=-1 3988 ll_greenwich=.FALSE. 3842 3989 3843 3990 IF( il_shape1(jp_J) == 1 )THEN 3844 3991 3845 3992 grid__get_fine_offset_cc(jp_J,:)=((id_rho(jp_J)-1)/2) 3846 3993 3847 ! work on i-direction 3848 ! look for i-direction left offset 3849 IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0) )THEN 3850 DO ji=1,id_rho(jp_I)+2 3851 IF( dl_lon1(ji,1) > dl_lon0(id_imin0+1,id_jmin0) - dp_delta )THEN 3852 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ji 3853 EXIT 3854 ENDIF 3855 ENDDO 3994 !!! work on i-direction 3995 !!! look for i-direction left offset 3996 i1=1 ; i2=MIN((id_rho(jp_I)+2),il_shape1(jp_I)) 3997 j1=1 ; j2=1 3998 3999 ! check if cross greenwich meridien 4000 IF( minval(dl_lon0(id_imin0:id_imin0+1,id_jmin0))<5. .OR. & 4001 & maxval(dl_lon0(id_imin0:id_imin0+1,id_jmin0))>355. )THEN 4002 ! close to greenwich meridien 4003 ll_greenwich=.TRUE. 4004 ! 0:360 => -180:180 4005 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0) > 180. ) 4006 dl_lon0(id_imin0:id_imin0+1,id_jmin0) = & 4007 & dl_lon0(id_imin0:id_imin0+1,id_jmin0)-360. 4008 END WHERE 4009 4010 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4011 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4012 END WHERE 4013 ENDIF 4014 4015 ! max lognitude of the left cell 4016 dl_lonmax0=dl_lon0(id_imin0+1,id_jmin0) 4017 IF( dl_lon1(1,1) < dl_lonmax0 )THEN 4018 4019 !!!!! i-direction !!!!! 4020 IF( ll_even(jp_I) )THEN 4021 ! even 4022 SELECT CASE(TRIM(cl_point)) 4023 CASE('F','U') 4024 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0) - & 4025 & dl_lon0(id_imin0 ,id_jmin0) ) / & 4026 & ( 2.*id_rho(jp_I) ) 4027 CASE DEFAULT 4028 dl_dlon=0 4029 END SELECT 4030 ELSE 4031 ! odd 4032 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0) - & 4033 & dl_lon0(id_imin0 ,id_jmin0) ) / & 4034 & ( 2.*id_rho(jp_I) ) 4035 ENDIF 4036 4037 dl_lon0F= dl_lon0(id_imin0+1,id_jmin0) + dl_dlon 4038 dl_lat0F= dd_lat0(id_imin0+1,id_jmin0) 4039 4040 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4041 & dl_lon0F, dl_lat0F, 'le' ) 4042 4043 ii=il_ind(1) 4044 4045 !!!!! i-direction !!!!! 4046 IF( ll_even(jp_I) )THEN 4047 ! even 4048 SELECT CASE(TRIM(cl_point)) 4049 CASE('T','V') 4050 grid__get_fine_offset_cc(jp_I,1)=id_rho(jp_I)-ii 4051 CASE DEFAULT !'F','U' 4052 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4053 END SELECT 4054 ELSE 4055 ! odd 4056 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4057 ENDIF 4058 3856 4059 ELSE 3857 4060 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3858 & " not match fine grid lower left corner.") 3859 ENDIF 3860 ! look for i-direction right offset 3861 IF( dl_lon1(il_shape1(jp_I),1) > dl_lon0(id_imax0-1,id_jmin0) )THEN 3862 DO ji=1,id_rho(jp_I)+2 3863 ii=il_shape1(jp_I)-ji+1 3864 IF( dl_lon1(ii,1) < dl_lon0(id_imax0-1,id_jmin0) + dp_delta )THEN 3865 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ji 3866 EXIT 3867 ENDIF 3868 ENDDO 4061 & " not match fine grid left corner.") 4062 ENDIF 4063 4064 IF( ll_greenwich )THEN 4065 ! close to greenwich meridien 4066 ll_greenwich=.FALSE. 4067 ! -180:180 => 0:360 4068 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0) < 0. ) 4069 dl_lon0(id_imin0:id_imin0+1,id_jmin0) = & 4070 & dl_lon0(id_imin0:id_imin0+1,id_jmin0)+360. 4071 END WHERE 4072 4073 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4074 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4075 END WHERE 4076 ENDIF 4077 4078 !!!!!! look for i-direction right offset !!!!!! 4079 i1=MAX(1,il_shape1(jp_I)-(id_rho(jp_I)+2)+1) ; i2=il_shape1(jp_I) 4080 j1=1 ; j2=1 4081 4082 ! check if cross greenwich meridien 4083 IF( minval(dl_lon0(id_imax0-1:id_imax0,id_jmin0))<5. .OR. & 4084 & maxval(dl_lon0(id_imax0-1:id_imax0,id_jmin0))>355. )THEN 4085 ! close to greenwich meridien 4086 ll_greenwich=.TRUE. 4087 ! 0:360 => -180:180 4088 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmin0) > 180. ) 4089 dl_lon0(id_imax0-1:id_imax0,id_jmin0) = & 4090 & dl_lon0(id_imax0-1:id_imax0,id_jmin0)-360. 4091 END WHERE 4092 4093 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4094 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4095 END WHERE 4096 ENDIF 4097 4098 ! min lognitude of the right cell 4099 dl_lonmin0=dl_lon0(id_imax0-1,id_jmin0) 4100 IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > dl_lonmin0 )THEN 4101 4102 !!!!! i-direction !!!!! 4103 IF( ll_even(jp_I) )THEN 4104 ! even 4105 SELECT CASE(TRIM(cl_point)) 4106 CASE('F','U') 4107 dl_dlon= ( dl_lon0(id_imax0 ,id_jmin0) - & 4108 & dl_lon0(id_imax0-1,id_jmin0) ) / & 4109 & ( 2.*id_rho(jp_I) ) 4110 CASE DEFAULT 4111 dl_dlon=0 4112 END SELECT 4113 ELSE 4114 ! odd 4115 dl_dlon= ( dl_lon0(id_imax0 ,id_jmin0) - & 4116 & dl_lon0(id_imax0-1,id_jmin0) ) / & 4117 & ( 2.*id_rho(jp_I) ) 4118 ENDIF 4119 4120 dl_lon0F= dl_lon0(id_imax0-1,id_jmin0) - dl_dlon 4121 dl_lat0F= dd_lat0(id_imax0-1,id_jmin0) 4122 4123 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4124 & dl_lon0F, dl_lat0F, 'ri' ) 4125 4126 ii=(MIN(il_shape1(jp_I),(id_rho(jp_I)+2))-il_ind(1)+1) 4127 4128 !!!!! i-direction !!!!! 4129 IF( ll_even(jp_I) )THEN 4130 ! even 4131 SELECT CASE(TRIM(cl_point)) 4132 CASE('T','V') 4133 grid__get_fine_offset_cc(jp_I,2)=id_rho(jp_I)-ii 4134 CASE DEFAULT !'F','U' 4135 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4136 END SELECT 4137 ELSE 4138 ! odd 4139 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4140 ENDIF 4141 3869 4142 ELSE 3870 4143 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3871 & " not match fine grid lower right corner.") 4144 & " not match fine grid right corner.") 4145 ENDIF 4146 4147 IF( ll_greenwich )THEN 4148 ! close to greenwich meridien 4149 ll_greenwich=.FALSE. 4150 ! -180:180 => 0:360 4151 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmin0) < 0. ) 4152 dl_lon0(id_imax0-1:id_imax0,id_jmin0) = & 4153 & dl_lon0(id_imax0-1:id_imax0,id_jmin0)+360. 4154 END WHERE 4155 4156 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4157 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4158 END WHERE 3872 4159 ENDIF 3873 4160 … … 3876 4163 grid__get_fine_offset_cc(jp_I,:)=((id_rho(jp_I)-1)/2) 3877 4164 3878 ! work on j-direction 3879 3880 ! look for j-direction lower offset 3881 IF( dd_lat1(1,1) < dd_lat0(id_imin0,id_jmin0+1) )THEN 3882 DO jj=1,id_rho(jp_J)+2 3883 IF( dd_lat1(1,jj) > dd_lat0(id_imin0,id_jmin0+1) - dp_delta )THEN 3884 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-jj 3885 EXIT 3886 ENDIF 3887 ENDDO 4165 !!! work on j-direction 4166 !!! look for j-direction lower offset 4167 i1=1 ; i2=1 4168 j1=1 ; j2=MIN((id_rho(jp_J)+2),il_shape1(jp_J)) 4169 4170 4171 ! max latitude of the lower cell 4172 dl_latmax0=dd_lat0(id_imin0,id_jmin0+1) 4173 IF( dd_lat1(1,1) < dl_latmax0 )THEN 4174 4175 IF( ll_even(jp_J) )THEN 4176 ! even 4177 SELECT CASE(TRIM(cl_point)) 4178 CASE('F','V') 4179 dl_dlat= ( dd_lat0(id_imin0,id_jmin0+1) - & 4180 & dd_lat0(id_imin0,id_jmin0 ) ) / & 4181 & ( 2.*id_rho(jp_J) ) 4182 CASE DEFAULT 4183 dl_dlat=0 4184 END SELECT 4185 ELSE 4186 ! odd 4187 dl_dlat= ( dd_lat0(id_imin0,id_jmin0+1) - & 4188 & dd_lat0(id_imin0,id_jmin0 ) ) / & 4189 & ( 2.*id_rho(jp_J) ) 4190 ENDIF 4191 4192 dl_lon0F= dl_lon0(id_imin0,id_jmin0+1) 4193 dl_lat0F= dd_lat0(id_imin0,id_jmin0+1) + dl_dlat 4194 4195 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4196 & dl_lon0F, dl_lat0F, 'lo' ) 4197 4198 ij=il_ind(2) 4199 4200 !!!!! i-direction !!!!! 4201 IF( ll_even(jp_I) )THEN 4202 ! even 4203 SELECT CASE(TRIM(cl_point)) 4204 CASE('T','V') 4205 grid__get_fine_offset_cc(jp_I,1)=id_rho(jp_I)-ii 4206 CASE DEFAULT !'F','U' 4207 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4208 END SELECT 4209 ELSE 4210 ! odd 4211 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4212 ENDIF 4213 3888 4214 ELSE 3889 4215 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3890 & " not match fine grid upper left corner.") 3891 ENDIF 3892 3893 ! look for j-direction upper offset 3894 IF( dd_lat1(1,il_shape1(jp_J)) > dd_lat0(id_imin0,id_jmax0-1) )THEN 3895 DO jj=1,id_rho(jp_J)+2 3896 ij=il_shape1(jp_J)-jj+1 3897 IF( dd_lat1(1,ij) < dd_lat0(id_imin0,id_jmax0-1) + dp_delta )THEN 3898 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-jj 3899 EXIT 3900 ENDIF 3901 ENDDO 4216 & " not match fine grid lower corner.") 4217 ENDIF 4218 4219 !!! look for j-direction upper offset 4220 i1=1 ; i2=1 4221 j1=MAX(1,il_shape1(jp_J)-(id_rho(jp_J)+2)+1) ; j2=il_shape1(jp_J) 4222 4223 ! min latitude of the upper cell 4224 dl_latmin0=dd_lat0(id_imin0,id_jmax0-1) 4225 IF( dd_lat1(il_shape1(jp_I),il_shape1(jp_J)) > dl_latmin0 )THEN 4226 4227 IF( ll_even(jp_J) )THEN 4228 ! even 4229 SELECT CASE(TRIM(cl_point)) 4230 CASE('F','V') 4231 dl_dlat= ( dd_lat0(id_imin0,id_jmax0 ) - & 4232 & dd_lat0(id_imin0,id_jmax0-1) ) / & 4233 & ( 2.*id_rho(jp_J) ) 4234 CASE DEFAULT 4235 dl_dlat=0 4236 END SELECT 4237 ELSE 4238 ! odd 4239 dl_dlat= ( dd_lat0(id_imin0,id_jmax0 ) - & 4240 & dd_lat0(id_imin0,id_jmax0-1) ) / & 4241 & ( 2*id_rho(jp_J) ) 4242 ENDIF 4243 4244 dl_lon0F= dl_lon0(id_imin0,id_jmax0-1) 4245 dl_lat0F= dd_lat0(id_imin0,id_jmax0-1) - dl_dlat 4246 4247 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4248 & dl_lon0F, dl_lat0F, 'up' ) 4249 4250 ij=(MIN(il_shape1(jp_J),(id_rho(jp_J)+2))-il_ind(2)+1) 4251 4252 !!!!! j-direction !!!!! 4253 IF( ll_even(jp_J) )THEN 4254 ! even 4255 SELECT CASE(TRIM(cl_point)) 4256 CASE('T','U') 4257 grid__get_fine_offset_cc(jp_J,2)=id_rho(jp_J)-ij 4258 CASE DEFAULT !'F','V' 4259 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4260 END SELECT 4261 ELSE 4262 ! odd 4263 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4264 ENDIF 4265 3902 4266 ELSE 3903 4267 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 4268 & " not match fine grid upper corner.") 4269 ENDIF 4270 4271 ELSE ! il_shape1(1) > 1 .AND. il_shape1(2) > 1 4272 4273 !!!!!! look for lower left offset !!!!!! 4274 i1=1 ; i2=MIN((id_rho(jp_I)+2),il_shape1(jp_I)) 4275 j1=1 ; j2=MIN((id_rho(jp_J)+2),il_shape1(jp_J)) 4276 4277 ! check if cross greenwich meridien 4278 IF( minval(dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1))<5. .OR. & 4279 & maxval(dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1))>355. )THEN 4280 ! close to greenwich meridien 4281 ll_greenwich=.TRUE. 4282 ! 0:360 => -180:180 4283 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) > 180. ) 4284 dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) = & 4285 & dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1)-360. 4286 END WHERE 4287 4288 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4289 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4290 END WHERE 4291 ENDIF 4292 4293 ! max longitude of the lower left cell 4294 dl_lonmax0=MAX(dl_lon0(id_imin0+1,id_jmin0),dl_lon0(id_imin0+1,id_jmin0+1)) 4295 ! max latitude of the lower left cell 4296 dl_latmax0=MAX(dd_lat0(id_imin0,id_jmin0+1),dd_lat0(id_imin0+1,id_jmin0+1)) 4297 IF( dl_lon1(1,1) < dl_lonmax0 .AND. & 4298 & dd_lat1(1,1) < dl_latmax0 )THEN 4299 4300 !!!!! i-direction !!!!! 4301 IF( ll_even(jp_I) )THEN 4302 ! even 4303 SELECT CASE(TRIM(cl_point)) 4304 CASE('F','U') 4305 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0+1) - & 4306 & dl_lon0(id_imin0 ,id_jmin0+1) ) / & 4307 & ( 2.*id_rho(jp_I) ) 4308 CASE DEFAULT 4309 dl_dlon=0 4310 END SELECT 4311 ELSE 4312 ! odd 4313 dl_dlon= ( dl_lon0(id_imin0+1,id_jmin0+1) - & 4314 & dl_lon0(id_imin0 ,id_jmin0+1) ) / & 4315 & ( 2.*id_rho(jp_I) ) 4316 ENDIF 4317 4318 !!!!! j-direction !!!!! 4319 IF( ll_even(jp_J) )THEN 4320 ! even 4321 SELECT CASE(TRIM(cl_point)) 4322 CASE('F','V') 4323 dl_dlat= ( dd_lat0(id_imin0+1,id_jmin0+1) - & 4324 & dd_lat0(id_imin0+1,id_jmin0 ) ) / & 4325 & ( 2.*id_rho(jp_J) ) 4326 CASE DEFAULT 4327 dl_dlat=0 4328 END SELECT 4329 ELSE 4330 ! odd 4331 dl_dlat= ( dd_lat0(id_imin0+1,id_jmin0+1) - & 4332 & dd_lat0(id_imin0+1,id_jmin0 ) ) / & 4333 & ( 2.*id_rho(jp_J) ) 4334 ENDIF 4335 4336 dl_lon0F= dl_lon0(id_imin0+1,id_jmin0+1) + dl_dlon 4337 dl_lat0F= dd_lat0(id_imin0+1,id_jmin0+1) + dl_dlat 4338 4339 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4340 & dl_lon0F, dl_lat0F, 'll' ) 4341 4342 ii=il_ind(1) 4343 ij=il_ind(2) 4344 4345 !!!!! i-direction !!!!! 4346 IF( ll_even(jp_I) )THEN 4347 ! even 4348 SELECT CASE(TRIM(cl_point)) 4349 CASE('T','V') 4350 grid__get_fine_offset_cc(jp_I,1)=id_rho(jp_I)-ii 4351 CASE DEFAULT !'F','U' 4352 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4353 END SELECT 4354 ELSE 4355 ! odd 4356 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 4357 ENDIF 4358 4359 !!!!! j-direction !!!!! 4360 IF( ll_even(jp_J) )THEN 4361 ! even 4362 SELECT CASE(TRIM(cl_point)) 4363 CASE('T','U') 4364 grid__get_fine_offset_cc(jp_J,1)=id_rho(jp_J)-ij 4365 CASE DEFAULT !'F','V' 4366 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-ij 4367 END SELECT 4368 ELSE 4369 ! odd 4370 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-ij 4371 ENDIF 4372 4373 ELSE 4374 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do"//& 4375 & " not match fine grid lower left corner.") 4376 ENDIF 4377 4378 IF( ll_greenwich )THEN 4379 ! close to greenwich meridien 4380 ll_greenwich=.FALSE. 4381 ! -180:180 => 0:360 4382 WHERE( dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) < 0. ) 4383 dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1) = & 4384 & dl_lon0(id_imin0:id_imin0+1,id_jmin0:id_jmin0+1)+360. 4385 END WHERE 4386 4387 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4388 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4389 END WHERE 4390 ENDIF 4391 4392 !!!!!! look for upper right offset !!!!!! 4393 i1=MAX(1,il_shape1(jp_I)-(id_rho(jp_I)+2)+1) ; i2=il_shape1(jp_I) 4394 j1=MAX(1,il_shape1(jp_J)-(id_rho(jp_J)+2)+1) ; j2=il_shape1(jp_J) 4395 4396 ! check if cross greenwich meridien 4397 IF( minval(dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0))<5. .OR. & 4398 & maxval(dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0))>355. )THEN 4399 ! close to greenwich meridien 4400 ll_greenwich=.TRUE. 4401 ! 0:360 => -180:180 4402 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) > 180. ) 4403 dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) = & 4404 & dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0)-360. 4405 END WHERE 4406 4407 WHERE( dl_lon1(i1:i2,j1:j2) > 180. ) 4408 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)-360. 4409 END WHERE 4410 ENDIF 4411 4412 ! min latitude of the upper right cell 4413 dl_lonmin0=MIN(dl_lon0(id_imax0-1,id_jmax0-1),dl_lon0(id_imax0-1,id_jmax0)) 4414 ! min latitude of the upper right cell 4415 dl_latmin0=MIN(dd_lat0(id_imax0-1,id_jmax0-1),dd_lat0(id_imax0,id_jmax0-1)) 4416 IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > dl_lonmin0 .AND. & 4417 & dd_lat1(il_shape1(jp_I),il_shape1(jp_J)) > dl_latmin0 )THEN 4418 4419 !!!!! i-direction !!!!! 4420 IF( ll_even(jp_I) )THEN 4421 ! even 4422 SELECT CASE(TRIM(cl_point)) 4423 CASE('F','U') 4424 dl_dlon= ( dl_lon0(id_imax0 ,id_jmax0-1) - & 4425 & dl_lon0(id_imax0-1,id_jmax0-1) ) / & 4426 & ( 2.*id_rho(jp_I) ) 4427 CASE DEFAULT 4428 dl_dlon=0 4429 END SELECT 4430 ELSE 4431 ! odd 4432 dl_dlon= ( dl_lon0(id_imax0 ,id_jmax0-1) - & 4433 & dl_lon0(id_imax0-1,id_jmax0-1) ) / & 4434 & ( 2*id_rho(jp_I) ) 4435 ENDIF 4436 4437 !!!!! j-direction !!!!! 4438 IF( ll_even(jp_J) )THEN 4439 ! even 4440 SELECT CASE(TRIM(cl_point)) 4441 CASE('F','V') 4442 dl_dlat= ( dd_lat0(id_imax0-1,id_jmax0 ) - & 4443 & dd_lat0(id_imax0-1,id_jmax0-1) ) / & 4444 & ( 2.*id_rho(jp_J) ) 4445 CASE DEFAULT 4446 dl_dlat=0 4447 END SELECT 4448 ELSE 4449 ! odd 4450 dl_dlat= ( dd_lat0(id_imax0-1,id_jmax0 ) - & 4451 & dd_lat0(id_imax0-1,id_jmax0-1) ) / & 4452 & ( 2*id_rho(jp_J) ) 4453 ENDIF 4454 4455 dl_lon0F= dl_lon0(id_imax0-1,id_jmax0-1) - dl_dlon 4456 dl_lat0F= dd_lat0(id_imax0-1,id_jmax0-1) - dl_dlat 4457 4458 il_ind(:)=grid_get_closest( dl_lon1(i1:i2,j1:j2), dd_lat1(i1:i2,j1:j2), & 4459 & dl_lon0F, dl_lat0F, 'ur' ) 4460 4461 ii=(MIN(il_shape1(jp_I),(id_rho(jp_I)+2))-il_ind(1)+1) 4462 ij=(MIN(il_shape1(jp_J),(id_rho(jp_J)+2))-il_ind(2)+1) 4463 4464 !!!!! i-direction !!!!! 4465 IF( ll_even(jp_I) )THEN 4466 ! even 4467 SELECT CASE(TRIM(cl_point)) 4468 CASE('T','V') 4469 grid__get_fine_offset_cc(jp_I,2)=id_rho(jp_I)-ii 4470 CASE DEFAULT !'F','U' 4471 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4472 END SELECT 4473 ELSE 4474 ! odd 4475 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-ii 4476 ENDIF 4477 4478 !!!!! j-direction !!!!! 4479 IF( ll_even(jp_J) )THEN 4480 ! even 4481 SELECT CASE(TRIM(cl_point)) 4482 CASE('T','U') 4483 grid__get_fine_offset_cc(jp_J,2)=id_rho(jp_J)-ij 4484 CASE DEFAULT !'F','V' 4485 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4486 END SELECT 4487 ELSE 4488 ! odd 4489 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-ij 4490 ENDIF 4491 4492 ELSE 4493 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do"//& 3904 4494 & " not match fine grid upper right corner.") 3905 ENDIF 3906 3907 ELSE ! il_shape1(1) > 1 .AND. il_shape1(2) > 1 3908 3909 ! look for lower left offset 3910 IF( dl_lon1(1,1) < dl_lon0(id_imin0+1,id_jmin0+1) )THEN 3911 3912 ii=1 3913 ij=1 3914 DO ji=1,(id_rho(jp_I)+2)*(id_rho(jp_J)+2) 3915 3916 ll_ii=.FALSE. 3917 ll_ij=.FALSE. 3918 3919 IF( dl_lon1(ii,ij) >= dl_lon0(id_imin0+1,id_jmin0+1)-dp_delta .AND. & 3920 & dd_lat1(ii,ij) >= dd_lat0(id_imin0+1,id_jmin0+1)-dp_delta )THEN 3921 grid__get_fine_offset_cc(jp_I,1)=(id_rho(jp_I)+1)-ii 3922 grid__get_fine_offset_cc(jp_J,1)=(id_rho(jp_J)+1)-ij 3923 EXIT 3924 ENDIF 3925 3926 IF( dl_lon1(ii+1,ij) <= dl_lon0(id_imin0+1,id_jmin0+1)+dp_delta .AND. & 3927 & dd_lat1(ii+1,ij) <= dd_lat0(id_imin0+1,id_jmin0+1)+dp_delta )THEN 3928 ll_ii=.TRUE. 3929 ENDIF 3930 IF( dl_lon1(ii,ij+1) <= dl_lon0(id_imin0+1,id_jmin0+1)+dp_delta .AND. & 3931 & dd_lat1(ii,ij+1) <= dd_lat0(id_imin0+1,id_jmin0+1)+dp_delta )THEN 3932 ll_ij=.TRUE. 3933 ENDIF 3934 3935 IF( ll_ii ) ii=ii+1 3936 IF( ll_ij ) ij=ij+1 3937 3938 ENDDO 3939 3940 ELSE 3941 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3942 & " not match fine grid lower left corner.") 3943 ENDIF 3944 3945 ! look for upper right offset 3946 IF( dl_lon1(il_shape1(jp_I),il_shape1(jp_J)) > & 3947 & dl_lon0(id_imax0-1,id_jmax0-1) )THEN 3948 3949 ii=il_shape1(jp_I) 3950 ij=il_shape1(jp_J) 3951 DO ji=1,(id_rho(jp_I)+2)*(id_rho(jp_J)+2) 3952 3953 ll_ii=.FALSE. 3954 ll_ij=.FALSE. 3955 3956 IF( dl_lon1(ii,ij) <= dl_lon0(id_imax0-1,id_jmax0-1)+dp_delta .AND. & 3957 & dd_lat1(ii,ij) <= dd_lat0(id_imax0-1,id_jmax0-1)+dp_delta )THEN 3958 grid__get_fine_offset_cc(jp_I,2)=(id_rho(jp_I)+1)-(il_shape1(jp_I)+1-ii) 3959 grid__get_fine_offset_cc(jp_J,2)=(id_rho(jp_J)+1)-(il_shape1(jp_J)+1-ij) 3960 EXIT 3961 ENDIF 3962 3963 IF( dl_lon1(ii-1,ij) >= dl_lon0(id_imax0-1,id_jmax0-1)-dp_delta .AND. & 3964 & dd_lat1(ii-1,ij) >= dd_lat0(id_imax0-1,id_jmax0-1)-dp_delta )THEN 3965 ll_ii=.TRUE. 3966 ENDIF 3967 IF( dl_lon1(ii,ij-1) >= dl_lon0(id_imax0-1,id_jmax0-1)-dp_delta .AND. & 3968 & dd_lat1(ii,ij-1) >= dd_lat0(id_imax0-1,id_jmax0-1)-dp_delta )THEN 3969 ll_ij=.TRUE. 3970 ENDIF 3971 3972 IF( ll_ii ) ii=ii-1 3973 IF( ll_ij ) ij=ij-1 3974 3975 ENDDO 3976 3977 ELSE 3978 CALL logger_error("GRID GET FINE OFFSET: coarse grid indices do "//& 3979 & " not match fine grid upper right corner.") 4495 ENDIF 4496 4497 IF( ll_greenwich )THEN 4498 ! close to greenwich meridien 4499 ll_greenwich=.FALSE. 4500 ! -180:180 => 0:360 4501 WHERE( dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) < 0. ) 4502 dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0) = & 4503 & dl_lon0(id_imax0-1:id_imax0,id_jmax0-1:id_jmax0)+360. 4504 END WHERE 4505 4506 WHERE( dl_lon1(i1:i2,j1:j2) < 0. ) 4507 dl_lon1(i1:i2,j1:j2)=dl_lon1(i1:i2,j1:j2)+360. 4508 END WHERE 3980 4509 ENDIF 3981 4510 … … 3984 4513 DEALLOCATE( dl_lon0 ) 3985 4514 DEALLOCATE( dl_lon1 ) 4515 4516 IF( ANY(grid__get_fine_offset_cc(:,:)==-1) )THEN 4517 CALL logger_fatal("GRID GET FINE OFFSET: can not found "//& 4518 & " offset between coarse and fine grid.") 4519 ENDIF 3986 4520 3987 4521 END FUNCTION grid__get_fine_offset_cc … … 3995 4529 !> @date October, 2014 3996 4530 !> - work on mpp file structure instead of file structure 3997 ! 4531 !> @date February, 2016 4532 !> - use F-point to check coincidence for even refinment 4533 !> - use F-point estimation, if can not read it. 4534 !> 3998 4535 !> @param[in] td_coord0 coarse grid coordinate file structure 3999 4536 !> @param[in] td_coord1 fine grid coordinate file structure … … 4020 4557 4021 4558 ! local variable 4022 INTEGER(i4) :: il_imid14023 INTEGER(i4) :: il_jmid14559 INTEGER(i4) :: il_imid1 4560 INTEGER(i4) :: il_jmid1 4024 4561 4025 INTEGER(i4) :: il_ew0 4026 INTEGER(i4) :: il_ew1 4027 4028 INTEGER(i4) :: il_imin1 4029 INTEGER(i4) :: il_imax1 4030 INTEGER(i4) :: il_jmin1 4031 INTEGER(i4) :: il_jmax1 4032 4033 INTEGER(i4), DIMENSION(2) :: il_indC 4034 INTEGER(i4), DIMENSION(2) :: il_indF 4035 INTEGER(i4), DIMENSION(2) :: il_iind 4036 INTEGER(i4), DIMENSION(2) :: il_jind 4037 4038 REAL(dp) :: dl_lon0 4039 REAL(dp) :: dl_lat0 4040 REAL(dp) :: dl_lon1 4041 REAL(dp) :: dl_lat1 4042 4043 REAL(dp) :: dl_lon1p 4044 REAL(dp) :: dl_lat1p 4045 4046 LOGICAL :: ll_coincidence 4047 4048 TYPE(TVAR) :: tl_lon0 4049 TYPE(TVAR) :: tl_lat0 4050 TYPE(TVAR) :: tl_lon1 4051 TYPE(TVAR) :: tl_lat1 4052 4053 TYPE(TMPP) :: tl_coord0 4054 TYPE(TMPP) :: tl_coord1 4055 4056 TYPE(TDOM) :: tl_dom0 4562 INTEGER(i4) :: il_ew0 4563 INTEGER(i4) :: il_ew1 4564 4565 INTEGER(i4) :: il_ind 4566 4567 INTEGER(i4) :: il_imin1 4568 INTEGER(i4) :: il_imax1 4569 INTEGER(i4) :: il_jmin1 4570 INTEGER(i4) :: il_jmax1 4571 4572 INTEGER(i4), DIMENSION(2) :: il_ind0 4573 INTEGER(i4), DIMENSION(2) :: il_ind1 4574 4575 INTEGER(i4), DIMENSION(2) :: il_ill1 4576 INTEGER(i4), DIMENSION(2) :: il_ilr1 4577 INTEGER(i4), DIMENSION(2) :: il_iul1 4578 INTEGER(i4), DIMENSION(2) :: il_iur1 4579 4580 REAL(dp) :: dl_lon0F 4581 REAL(dp) :: dl_lat0F 4582 REAL(dp) :: dl_lon0 4583 REAL(dp) :: dl_lat0 4584 REAL(dp) :: dl_lon1F 4585 REAL(dp) :: dl_lat1F 4586 REAL(dp) :: dl_lon1 4587 REAL(dp) :: dl_lat1 4588 4589 REAL(dp) :: dl_delta 4590 4591 LOGICAL :: ll_coincidence 4592 LOGICAL :: ll_even 4593 LOGICAL :: ll_grid0F 4594 LOGICAL :: ll_grid1F 4595 4596 TYPE(TVAR) :: tl_lon0 4597 TYPE(TVAR) :: tl_lat0 4598 TYPE(TVAR) :: tl_lon0F 4599 TYPE(TVAR) :: tl_lat0F 4600 TYPE(TVAR) :: tl_lon1 4601 TYPE(TVAR) :: tl_lat1 4602 TYPE(TVAR) :: tl_lon1F 4603 TYPE(TVAR) :: tl_lat1F 4604 4605 TYPE(TMPP) :: tl_coord0 4606 TYPE(TMPP) :: tl_coord1 4607 4608 TYPE(TDOM) :: tl_dom0 4057 4609 4058 4610 ! loop indices … … 4063 4615 ll_coincidence=.TRUE. 4064 4616 4617 ll_even=.FALSE. 4618 IF( MOD(id_rho(jp_I)*id_rho(jp_J),2) == 0 )THEN 4619 ll_even=.TRUE. 4620 ENDIF 4621 4065 4622 ! copy structure 4066 4623 tl_coord0=mpp_copy(td_coord0) … … 4075 4632 4076 4633 ! read variable value on domain 4077 tl_lon0=iom_dom_read_var(tl_coord0,'longitude',tl_dom0) 4078 tl_lat0=iom_dom_read_var(tl_coord0,'latitude' ,tl_dom0) 4634 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'longitude_T') 4635 IF( il_ind /= 0 )THEN 4636 tl_lon0=iom_dom_read_var(tl_coord0,'longitude_T',tl_dom0) 4637 ELSE 4638 tl_lon0=iom_dom_read_var(tl_coord0,'longitude',tl_dom0) 4639 ENDIF 4640 4641 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'latitude_T') 4642 IF( il_ind /= 0 )THEN 4643 tl_lat0=iom_dom_read_var(tl_coord0,'latitude_T' ,tl_dom0) 4644 ELSE 4645 tl_lat0=iom_dom_read_var(tl_coord0,'latitude' ,tl_dom0) 4646 ENDIF 4647 4648 IF( ll_even )THEN 4649 ! look for variable value on domain for F point 4650 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'longitude_F') 4651 IF( il_ind /= 0 )THEN 4652 tl_lon0F=iom_dom_read_var(tl_coord0,'longitude_F',tl_dom0) 4653 ENDIF 4654 4655 il_ind=var_get_index(tl_coord0%t_proc(1)%t_var(:), 'latitude_F') 4656 IF( il_ind /= 0 )THEN 4657 tl_lat0F=iom_dom_read_var(tl_coord0,'latitude_F' ,tl_dom0) 4658 ENDIF 4659 4660 ll_grid0F=.FALSE. 4661 IF( ASSOCIATED(tl_lon0F%d_value) .AND. & 4662 & ASSOCIATED(tl_lat0F%d_value) )THEN 4663 ll_grid0F=.TRUE. 4664 ENDIF 4665 4666 ENDIF 4079 4667 4080 4668 ! close mpp files … … 4092 4680 4093 4681 ! read fine longitue and latitude 4094 tl_lon1=iom_mpp_read_var(tl_coord1,'longitude') 4095 tl_lat1=iom_mpp_read_var(tl_coord1,'latitude') 4682 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), TRIM(tl_lon0%c_longname)) 4683 IF( il_ind /= 0 )THEN 4684 tl_lon1=iom_mpp_read_var(tl_coord1,TRIM(tl_lon0%c_longname)) 4685 ELSE 4686 tl_lon1=iom_mpp_read_var(tl_coord1,'longitude') 4687 ENDIF 4688 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), TRIM(tl_lat0%c_longname)) 4689 IF( il_ind /= 0 )THEN 4690 tl_lat1=iom_mpp_read_var(tl_coord1,TRIM(tl_lat0%c_longname)) 4691 ELSE 4692 tl_lat1=iom_mpp_read_var(tl_coord1,'latitude') 4693 ENDIF 4096 4694 4695 IF( ll_even )THEN 4696 4697 ! look for variable value on domain for F point 4698 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), 'longitude_F') 4699 IF( il_ind /= 0 )THEN 4700 tl_lon1F=iom_mpp_read_var(tl_coord1,'longitude_F') 4701 ENDIF 4702 4703 il_ind=var_get_index(tl_coord1%t_proc(1)%t_var(:), 'latitude_F') 4704 IF( il_ind /= 0 )THEN 4705 tl_lat1F=iom_mpp_read_var(tl_coord1,'latitude_F') 4706 ENDIF 4707 4708 ll_grid1F=.FALSE. 4709 IF( ASSOCIATED(tl_lon1F%d_value) .AND. & 4710 & ASSOCIATED(tl_lat1F%d_value) )THEN 4711 ll_grid1F=.TRUE. 4712 ENDIF 4713 4714 ENDIF 4715 4097 4716 ! close mpp files 4098 CALL iom_ dom_close(tl_coord1)4717 CALL iom_mpp_close(tl_coord1) 4099 4718 ! clean structure 4100 4719 CALL mpp_clean(tl_coord1) … … 4158 4777 IF( .NOT. ll_coincidence )THEN 4159 4778 CALL logger_fatal("GRID CHECK COINCIDENCE: no coincidence "//& 4160 & "between fine grid and coarse grid . invalid domain" )4779 & "between fine grid and coarse grid: invalid domain." ) 4161 4780 ENDIF 4162 4781 … … 4172 4791 4173 4792 ! select closest point on coarse grid 4174 il_ind C(:)=grid_get_closest(tl_lon0%d_value(:,:,1,1),&4793 il_ind0(:)=grid_get_closest(tl_lon0%d_value(:,:,1,1),& 4175 4794 & tl_lat0%d_value(:,:,1,1),& 4176 4795 & dl_lon1, dl_lat1 ) 4177 4796 4178 IF( ANY(il_ind C(:)==0) )THEN4797 IF( ANY(il_ind0(:)==0) )THEN 4179 4798 CALL logger_fatal("GRID CHECK COINCIDENCE: can not find valid "//& 4180 & "coarse grid indices. invalid domain" ) 4181 ENDIF 4182 4183 dl_lon0=tl_lon0%d_value(il_indC(1),il_indC(2),1,1) 4184 dl_lat0=tl_lat0%d_value(il_indC(1),il_indC(2),1,1) 4185 4186 ! look for closest fine grid point from selected coarse grid point 4187 il_iind(:)=MAXLOC( tl_lon1%d_value(:,:,1,1), & 4188 & tl_lon1%d_value(:,:,1,1) <= dl_lon0 ) 4189 4190 il_jind(:)=MAXLOC( tl_lat1%d_value(:,:,1,1), & 4191 & tl_lat1%d_value(:,:,1,1) <= dl_lat0 ) 4192 4193 il_indF(1)=il_iind(1) 4194 il_indF(2)=il_jind(2) 4195 4196 IF( ANY(il_indF(:)==0) )THEN 4197 CALL logger_fatal("GRID CHECK COINCIDENCE: can not find valid "//& 4198 & "fine grid indices. invalid domain" ) 4199 ENDIF 4200 4201 dl_lon1=tl_lon1%d_value(il_indF(1),il_indF(2),1,1) 4202 dl_lat1=tl_lat1%d_value(il_indF(1),il_indF(2),1,1) 4203 4204 ! check i-direction refinement factor 4205 DO ji=1,MIN(3,il_imid1) 4206 4207 IF( il_indF(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN 4208 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4209 & " to check i-direction refinement factor ") 4210 EXIT 4211 ELSE 4212 dl_lon1=tl_lon1%d_value(il_indF(1)+ji*id_rho(jp_I),il_indF(2),1,1) 4213 dl_lon0=tl_lon0%d_value(il_indC(1)+ji,il_indC(2),1,1) 4214 4215 dl_lon1p=tl_lon1%d_value(il_indF(1)+ji*id_rho(jp_I)+1,il_indF(2),1,1) 4216 4217 SELECT CASE(MOD(id_rho(jp_I),2)) 4218 4219 CASE(0) 4220 4221 IF( dl_lon1 >= dl_lon0 .OR. dl_lon0 >= dl_lon1p )THEN 4222 ll_coincidence=.FALSE. 4223 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 4224 & "i-direction refinement factor ("//& 4225 & TRIM(fct_str(id_rho(jp_I)))//& 4226 & ") between fine grid and coarse grid ") 4227 ENDIF 4228 4229 CASE DEFAULT 4230 4799 & "coarse grid indices: invalid domain." ) 4800 ENDIF 4801 4802 IF( .NOT. ll_even )THEN 4803 ! case odd refinment in both direction 4804 ! work on T-point 4805 4806 dl_lon0=tl_lon0%d_value(il_ind0(1),il_ind0(2),1,1) 4807 dl_lat0=tl_lat0%d_value(il_ind0(1),il_ind0(2),1,1) 4808 4809 il_ind1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4810 & tl_lat1%d_value(:,:,1,1),& 4811 & dl_lon0, dl_lat0 ) 4812 4813 ! check i-direction refinement factor 4814 DO ji=0,MIN(3,il_imid1) 4815 4816 IF( il_ind1(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN 4817 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4818 & " to check i-direction refinement factor ") 4819 EXIT 4820 ELSE 4821 dl_lon0=tl_lon0%d_value(il_ind0(1)+ji ,il_ind0(2),1,1) 4822 dl_lon1=tl_lon1%d_value(il_ind1(1)+ji*id_rho(jp_I),il_ind1(2),1,1) 4823 4824 ! assume there could be little difference due to interpolation 4231 4825 IF( ABS(dl_lon1 - dl_lon0) > dp_delta )THEN 4232 4826 ll_coincidence=.FALSE. … … 4236 4830 & ") between fine grid and coarse grid ") 4237 4831 ENDIF 4238 4239 END SELECT 4240 ENDIF 4241 4242 ENDDO 4243 4244 ! check j-direction refinement factor 4245 DO jj=1,MIN(3,il_jmid1) 4246 4247 IF( il_indF(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN 4248 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4249 & " to check j-direction refinement factor ") 4250 EXIT 4251 ELSE 4252 dl_lat1=tl_lat1%d_value(il_indF(1),il_indF(2)+jj*id_rho(jp_J),1,1) 4253 dl_lat0=tl_lat0%d_value(il_indC(1),il_indC(2)+jj,1,1) 4254 4255 dl_lat1p=tl_lat1%d_value(il_indF(1),il_indF(2)+jj*id_rho(jp_J)+1,1,1) 4256 4257 SELECT CASE(MOD(id_rho(jp_J),2)) 4258 4259 CASE(0) 4260 4261 IF( dl_lat1 >= dl_lat0 .OR. dl_lat0 >= dl_lat1p )THEN 4262 ll_coincidence=.FALSE. 4263 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 4264 & "j-direction refinement factor ("//& 4265 & TRIM(fct_str(id_rho(jp_J)))//& 4266 & ") between fine grid and coarse grid ") 4267 ENDIF 4268 4269 CASE DEFAULT 4270 4832 ENDIF 4833 4834 ENDDO 4835 4836 ! check j-direction refinement factor 4837 DO jj=0,MIN(3,il_jmid1) 4838 4839 IF( il_ind1(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN 4840 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4841 & " to check j-direction refinement factor ") 4842 EXIT 4843 ELSE 4844 dl_lat0=tl_lat0%d_value(il_ind0(1),il_ind0(2)+jj ,1,1) 4845 dl_lat1=tl_lat1%d_value(il_ind1(1),il_ind1(2)+jj*id_rho(jp_J),1,1) 4846 4847 ! assume there could be little difference due to interpolation 4271 4848 IF( ABS(dl_lat1-dl_lat0) > dp_delta )THEN 4272 4849 ll_coincidence=.FALSE. … … 4276 4853 & ") between fine grid and coarse grid ") 4277 4854 ENDIF 4278 4279 END SELECT 4280 ENDIF 4281 4282 ENDDO 4855 ENDIF 4856 4857 ENDDO 4858 4859 ELSE 4860 ! case even refinment at least in one direction 4861 ! work on F-point 4862 4863 dl_delta=dp_delta 4864 ! look for lower left fine point in coarse cell. 4865 IF( ll_grid0F )THEN 4866 4867 ! lower left corner of coarse cell 4868 dl_lon0F=tl_lon0F%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) 4869 dl_lat0F=tl_lat0F%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) 4870 4871 ELSE 4872 4873 ! approximate lower left corner of coarse cell (with T point) 4874 dl_lon0F=( tl_lon0%d_value(il_ind0(1) ,il_ind0(2) ,1,1) + & 4875 & tl_lon0%d_value(il_ind0(1) ,il_ind0(2)-1,1,1) + & 4876 & tl_lon0%d_value(il_ind0(1)-1,il_ind0(2) ,1,1) + & 4877 & tl_lon0%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) ) * 0.25 4878 4879 dl_lat0F=( tl_lat0%d_value(il_ind0(1) ,il_ind0(2) ,1,1) + & 4880 & tl_lat0%d_value(il_ind0(1) ,il_ind0(2)-1,1,1) + & 4881 & tl_lat0%d_value(il_ind0(1)-1,il_ind0(2) ,1,1) + & 4882 & tl_lat0%d_value(il_ind0(1)-1,il_ind0(2)-1,1,1) ) * 0.25 4883 4884 ! as we use approximation of F-point we relax condition 4885 dl_delta=100*dp_delta 4886 4887 ENDIF 4888 4889 IF( ll_grid1F )THEN 4890 4891 il_ind1(:)=grid_get_closest(tl_lon1F%d_value(:,:,1,1),& 4892 & tl_lat1F%d_value(:,:,1,1),& 4893 & dl_lon0F, dl_lat0F ) 4894 4895 ELSE 4896 4897 il_ill1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4898 & tl_lat1%d_value(:,:,1,1),& 4899 & dl_lon0F, dl_lat0F, 'll' ) 4900 4901 il_ilr1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4902 & tl_lat1%d_value(:,:,1,1),& 4903 & dl_lon0F, dl_lat0F, 'lr' ) 4904 4905 il_iul1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4906 & tl_lat1%d_value(:,:,1,1),& 4907 & dl_lon0F, dl_lat0F, 'ul' ) 4908 4909 il_iur1(:)=grid_get_closest(tl_lon1%d_value(:,:,1,1),& 4910 & tl_lat1%d_value(:,:,1,1),& 4911 & dl_lon0F, dl_lat0F, 'ur' ) 4912 4913 ! as we use approximation of F-point we relax condition 4914 dl_delta=100*dp_delta 4915 4916 ENDIF 4917 4918 ! check i-direction refinement factor 4919 DO ji=0,MIN(3,il_imid1) 4920 4921 IF( il_ind1(1)+ji*id_rho(jp_I)+1 > tl_lon1%t_dim(1)%i_len )THEN 4922 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4923 & " to check i-direction refinement factor ") 4924 EXIT 4925 ELSE 4926 IF( ll_grid0F )THEN 4927 dl_lon0F=tl_lon0F%d_value(il_ind0(1)+ji-1, il_ind0(2)-1,1,1) 4928 ELSE 4929 dl_lon0F= 0.25 * & 4930 & ( tl_lon0%d_value(il_ind0(1)+ji , il_ind0(2) ,1,1) + & 4931 & tl_lon0%d_value(il_ind0(1)+ji-1, il_ind0(2) ,1,1) + & 4932 & tl_lon0%d_value(il_ind0(1)+ji , il_ind0(2)-1,1,1) + & 4933 & tl_lon0%d_value(il_ind0(1)+ji-1, il_ind0(2)-1,1,1) ) 4934 ENDIF 4935 4936 IF( ll_grid1F )THEN 4937 dl_lon1F= tl_lon1F%d_value( il_ind1(1)+ji*id_rho(jp_I), & 4938 & il_ind1(2),1,1) 4939 ELSE 4940 dl_lon1F= 0.25 * & 4941 & ( tl_lon1%d_value( il_ill1(1)+ji*id_rho(jp_I), & 4942 & il_ill1(2),1,1) + & 4943 & tl_lon1%d_value( il_ilr1(1)+ji*id_rho(jp_I), & 4944 & il_ilr1(2),1,1) + & 4945 & tl_lon1%d_value( il_iul1(1)+ji*id_rho(jp_I), & 4946 & il_iul1(2),1,1) + & 4947 & tl_lon1%d_value( il_iur1(1)+ji*id_rho(jp_I), & 4948 & il_iur1(2),1,1) ) 4949 4950 ENDIF 4951 4952 ! assume there could be little difference due to interpolation 4953 IF( ABS(dl_lon1F - dl_lon0F) > dl_delta )THEN 4954 ll_coincidence=.FALSE. 4955 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 4956 & "i-direction refinement factor ("//& 4957 & TRIM(fct_str(id_rho(jp_I)))//& 4958 & ") between fine grid and coarse grid ") 4959 ENDIF 4960 ENDIF 4961 4962 ENDDO 4963 4964 ! check j-direction refinement factor 4965 DO jj=0,MIN(3,il_jmid1) 4966 4967 IF( il_ind1(2)+jj*id_rho(jp_J)+1 > tl_lat1%t_dim(2)%i_len )THEN 4968 CALL logger_warn("GRID CHECK COINCIDENCE: domain to small "//& 4969 & " to check j-direction refinement factor ") 4970 EXIT 4971 ELSE 4972 IF( ll_grid0F )THEN 4973 dl_lat0F=tl_lat0F%d_value(il_ind0(1)-1, il_ind0(2)+jj-1,1,1) 4974 ELSE 4975 dl_lat0F= 0.25 * & 4976 & ( tl_lat0%d_value(il_ind0(1) , il_ind0(2)+jj ,1,1) + & 4977 & tl_lat0%d_value(il_ind0(1)-1, il_ind0(2)+jj ,1,1) + & 4978 & tl_lat0%d_value(il_ind0(1) , il_ind0(2)+jj-1,1,1) + & 4979 & tl_lat0%d_value(il_ind0(1)-1, il_ind0(2)+jj-1,1,1) ) 4980 ENDIF 4981 4982 IF( ll_grid1F )THEN 4983 dl_lat1F= tl_lat1F%d_value( il_ind1(1), & 4984 & il_ind1(2)+jj*id_rho(jp_J),1,1) 4985 ELSE 4986 dl_lat1F= 0.25 * & 4987 & ( tl_lat1%d_value( il_ill1(1), & 4988 & il_ill1(2)+jj*id_rho(jp_J),1,1) + & 4989 & tl_lat1%d_value( il_ilr1(1), & 4990 & il_ilr1(2)+jj*id_rho(jp_J),1,1) + & 4991 & tl_lat1%d_value( il_iul1(1), & 4992 & il_iul1(2)+jj*id_rho(jp_J),1,1) + & 4993 & tl_lat1%d_value( il_iur1(1), & 4994 & il_iur1(2)+jj*id_rho(jp_J),1,1) ) 4995 4996 ENDIF 4997 4998 ! assume there could be little difference due to interpolation 4999 IF( ABS(dl_lat1F - dl_lat0F) > dl_delta )THEN 5000 ll_coincidence=.FALSE. 5001 CALL logger_debug("GRID CHECK COINCIDENCE: invalid "//& 5002 & "i-direction refinement factor ("//& 5003 & TRIM(fct_str(id_rho(jp_I)))//& 5004 & ") between fine grid and coarse grid ") 5005 ENDIF 5006 ENDIF 5007 5008 ENDDO 5009 ENDIF 4283 5010 4284 5011 ! clean … … 4851 5578 4852 5579 ! copy structure 4853 4854 4855 4856 4857 4858 4859 5580 tl_mpp=mpp_copy(td_mpp) 5581 5582 CALL logger_info("GRID GET FINE GHOST perio"//TRIM(fct_str(tl_mpp%i_perio))) 5583 IF( tl_mpp%i_perio < 0 )THEN 5584 ! compute NEMO periodicity index 5585 CALL grid_get_info(tl_mpp) 5586 ENDIF 4860 5587 4861 5588 SELECT CASE(tl_mpp%i_perio) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/interp_linear.f90
r5616 r6455 627 627 628 628 IF( ld_even(jp_I) )THEN 629 dl_dx=1. /REAL(id_rho(jp_I)-1)629 dl_dx=1._dp/REAL(id_rho(jp_I)-1,dp) 630 630 ELSE ! odd refinement 631 dl_dx=1. /REAL(id_rho(jp_I))631 dl_dx=1._dp/REAL(id_rho(jp_I),dp) 632 632 ENDIF 633 633 634 634 IF( ld_even(jp_J) )THEN 635 dl_dy=1. /REAL(id_rho(jp_J)-1)635 dl_dy=1._dp/REAL(id_rho(jp_J)-1,dp) 636 636 ELSE ! odd refinement 637 dl_dy=1. /REAL(id_rho(jp_J))637 dl_dy=1._dp/REAL(id_rho(jp_J),dp) 638 638 ENDIF 639 639 … … 642 642 643 643 IF( ld_even(jp_J) )THEN 644 dl_y= (jj-1)*dl_dy - dl_dy*0.5644 dl_y=REAL(jj-1,dp)*dl_dy - dl_dy*0.5_dp 645 645 ELSE ! odd refinement 646 dl_y= (jj-1)*dl_dy646 dl_y=REAL(jj-1,dp)*dl_dy 647 647 ENDIF 648 648 … … 653 653 654 654 IF( ld_even(jp_I) )THEN 655 dl_x= (ji-1)*dl_dx - dl_dx*0.5655 dl_x=REAL(ji-1,dp)*dl_dx - dl_dx*0.5_dp 656 656 ELSE ! odd refinement 657 dl_x= (ji-1)*dl_dx657 dl_x=REAL(ji-1,dp)*dl_dx 658 658 ENDIF 659 659 … … 692 692 693 693 IF( ld_even )THEN 694 dl_dx=1. /REAL(id_rho-1)694 dl_dx=1._dp/REAL(id_rho-1,dp) 695 695 ELSE ! odd refinement 696 dl_dx=1. /REAL(id_rho)696 dl_dx=1._dp/REAL(id_rho,dp) 697 697 ENDIF 698 698 699 699 DO ji=1,id_rho+1 700 700 IF( ld_even )THEN 701 dl_x= (ji-1)*dl_dx - dl_dx*0.5701 dl_x=REAL(ji-1,dp)*dl_dx - dl_dx*0.5_dp 702 702 ELSE ! odd refinement 703 dl_x= (ji-1)*dl_dx703 dl_x=REAL(ji-1,dp)*dl_dx 704 704 ENDIF 705 705 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/iom_cdf.f90
r5616 r6455 214 214 & cmode=NF90_64BIT_OFFSET,& 215 215 & ncid=td_file%i_id) 216 !NF90_WRITE, &217 216 CALL iom_cdf__check(il_status," IOM CDF CREATE: ") 218 217 … … 222 221 223 222 ELSE 223 224 224 IF( td_file%i_id /= 0 )THEN 225 225 … … 239 239 CALL iom_cdf__check(il_status," IOM CDF OPEN: ") 240 240 241 CALL logger_trace("IOM CDF OPEN "//TRIM(td_file%c_name)//" "//&242 & TRIM(fct_str(td_file%i_id)))243 241 ELSE 244 242 … … 363 361 ! Argument 364 362 TYPE(TFILE), INTENT(INOUT) :: td_file 363 ! local variable 364 TYPE(TDIM) :: tl_dim 365 365 366 366 ! loop indices 367 367 INTEGER(i4) :: ji 368 INTEGER(i4) :: ii 368 369 !---------------------------------------------------------------- 369 370 … … 374 375 375 376 IF( td_file%i_ndim > 0 )THEN 377 ii=1 376 378 DO ji = 1, td_file%i_ndim 377 379 ! read dimension information 378 td_file%t_dim(ji)=iom_cdf_read_dim( td_file, ji) 380 tl_dim=iom_cdf_read_dim( td_file, ji) 381 IF( .NOT. dim_is_dummy(tl_dim) )THEN 382 IF( ii > ip_maxdim )THEN 383 CALL logger_fatal("IOM CDF OPEN: too much dimension "//& 384 & "to be read. you should remove dummy dimension using "//& 385 & " configuration file") 386 ENDIF 387 td_file%t_dim(ii)=dim_copy(tl_dim) 388 ii=ii+1 389 ENDIF 379 390 ENDDO 380 391 … … 418 429 419 430 ! local variable 431 TYPE(TATT) :: tl_att 432 420 433 ! loop indices 421 434 INTEGER(i4) :: ji 435 INTEGER(i4) :: ii 422 436 !---------------------------------------------------------------- 423 437 … … 429 443 ALLOCATE(td_file%t_att(td_file%i_natt)) 430 444 445 ii=1 431 446 DO ji = 1, td_file%i_natt 432 447 ! read global attribute 433 td_file%t_att(ji)=iom_cdf_read_att( td_file, NF90_GLOBAL, ji) 448 tl_att=iom_cdf_read_att( td_file, NF90_GLOBAL, ji) 449 IF( .NOT. att_is_dummy(tl_att) )THEN 450 td_file%t_att(ii)=att_copy(tl_att) 451 ii=ii+1 452 ENDIF 434 453 435 454 ENDDO … … 450 469 !> @author J.Paul 451 470 !> @date November, 2013 - Initial Version 471 !> @date September, 2015 472 !> - manage useless (dummy) variable 473 !> @date January, 2016 474 !> - increment n3d for 4D variable 452 475 ! 453 476 !> @param[inout] td_file file structure … … 460 483 ! local variable 461 484 INTEGER(i4) :: il_attid 485 INTEGER(i4) :: il_nvar 486 487 TYPE(TVAR), DIMENSION(:), ALLOCATABLE :: tl_var 462 488 463 489 ! loop indices 464 490 INTEGER(i4) :: ji 491 INTEGER(i4) :: ii 465 492 !---------------------------------------------------------------- 466 493 467 494 IF( td_file%i_nvar > 0 )THEN 495 468 496 IF(ASSOCIATED(td_file%t_var))THEN 469 497 CALL var_clean(td_file%t_var(:)) 470 498 DEALLOCATE(td_file%t_var) 471 499 ENDIF 500 501 il_nvar=td_file%i_nvar 502 ALLOCATE(tl_var(il_nvar)) 503 ii=0 504 DO ji = 1, il_nvar 505 ! read variable information 506 tl_var(ji)=iom_cdf__read_var_meta( td_file, ji) 507 IF( .NOT. var_is_dummy(tl_var(ji)) )THEN 508 ii=ii+1 509 ENDIF 510 ENDDO 511 512 ! update number of variable used 513 td_file%i_nvar=ii 514 472 515 ALLOCATE(td_file%t_var(td_file%i_nvar)) 473 516 474 DO ji = 1, td_file%i_nvar 475 ! read dimension information 476 td_file%t_var(ji)=iom_cdf__read_var_meta( td_file, ji) 477 SELECT CASE(td_file%t_var(ji)%i_ndim) 478 CASE(0) 479 td_file%i_n0d=td_file%i_n0d+1 480 CASE(1) 481 td_file%i_n1d=td_file%i_n1d+1 482 td_file%i_rhd=td_file%i_rhd+1 483 CASE(2) 484 td_file%i_n2d=td_file%i_n2d+1 485 td_file%i_rhd=td_file%i_rhd+1 486 CASE(3) 487 td_file%i_n3d=td_file%i_n3d+1 488 td_file%i_rhd=td_file%i_rhd+td_file%t_dim(3)%i_len 489 END SELECT 490 491 ! look for depth id 492 IF( INDEX(TRIM(fct_lower(td_file%t_var(ji)%c_name)),'depth')/=0 )THEN 493 IF( td_file%i_depthid == 0 )THEN 494 td_file%i_depthid=ji 495 ELSE 496 IF( td_file%i_depthid /= ji )THEN 497 CALL logger_error("IOM CDF GET FILE VAR: find more"//& 498 & " than one depth variable in file "//& 499 & TRIM(td_file%c_name) ) 517 ii=0 518 DO ji = 1, il_nvar 519 IF( .NOT. var_is_dummy(tl_var(ji)) )THEN 520 ii=ii+1 521 td_file%t_var(ii)=var_copy(tl_var(ji)) 522 SELECT CASE(td_file%t_var(ii)%i_ndim) 523 CASE(0) 524 td_file%i_n0d=td_file%i_n0d+1 525 CASE(1) 526 td_file%i_n1d=td_file%i_n1d+1 527 td_file%i_rhd=td_file%i_rhd+1 528 CASE(2) 529 td_file%i_n2d=td_file%i_n2d+1 530 td_file%i_rhd=td_file%i_rhd+1 531 CASE(3,4) 532 td_file%i_n3d=td_file%i_n3d+1 533 td_file%i_rhd=td_file%i_rhd+td_file%t_dim(3)%i_len 534 END SELECT 535 536 ! look for depth id 537 IF( INDEX(TRIM(fct_lower(td_file%t_var(ii)%c_name)),'depth')/=0 )THEN 538 IF( td_file%i_depthid == 0 )THEN 539 td_file%i_depthid=ji 540 ELSE 541 IF( td_file%i_depthid /= ji )THEN 542 CALL logger_error("IOM CDF GET FILE VAR: find more"//& 543 & " than one depth variable in file "//& 544 & TRIM(td_file%c_name) ) 545 ENDIF 500 546 ENDIF 501 547 ENDIF 502 ENDIF 503 504 ! look for time id 505 IF( INDEX(TRIM(fct_lower(td_file%t_var(ji)%c_name)),'time')/=0 )THEN 506 IF( td_file%i_timeid == 0 )THEN 507 td_file%i_timeid=ji 508 ELSE 509 il_attid=0 510 IF( ASSOCIATED(td_file%t_var(ji)%t_att) )THEN 511 il_attid=att_get_id(td_file%t_var(ji)%t_att(:),'calendar') 512 ENDIF 513 IF( il_attid /= 0 )THEN 548 549 ! look for time id 550 IF( INDEX(TRIM(fct_lower(td_file%t_var(ii)%c_name)),'time')/=0 )THEN 551 IF( td_file%i_timeid == 0 )THEN 514 552 td_file%i_timeid=ji 515 !ELSE 516 ! CALL logger_error("IOM CDF GET FILE VAR: find more "//& 517 ! & "than one time variable in file "//& 518 ! & TRIM(td_file%c_name) ) 553 ELSE 554 il_attid=0 555 IF( ASSOCIATED(td_file%t_var(ii)%t_att) )THEN 556 il_attid=att_get_id(td_file%t_var(ii)%t_att(:),'calendar') 557 ENDIF 558 IF( il_attid /= 0 )THEN 559 td_file%i_timeid=ji 560 !ELSE 561 ! CALL logger_error("IOM CDF GET FILE VAR: find more "//& 562 ! & "than one time variable in file "//& 563 ! & TRIM(td_file%c_name) ) 564 ENDIF 519 565 ENDIF 520 566 ENDIF 567 521 568 ENDIF 522 523 569 ENDDO 570 571 CALL var_clean(tl_var(:)) 572 DEALLOCATE(tl_var) 524 573 525 574 ELSE … … 605 654 ELSE 606 655 607 iom_cdf__read_dim_id%i_id=id_dimid608 609 656 CALL logger_trace( & 610 657 & " IOM CDF READ DIM: dimension "//TRIM(fct_str(id_dimid))//& … … 627 674 ENDIF 628 675 676 iom_cdf__read_dim_id%i_id=id_dimid 677 629 678 END FUNCTION iom_cdf__read_dim_id 630 679 !------------------------------------------------------------------- … … 748 797 IF( LEN(cl_value) < il_len )THEN 749 798 750 CALL logger_ error( &799 CALL logger_warn( & 751 800 & " IOM CDF READ ATT: not enough space to put "//& 752 801 & "attribute "//TRIM(cl_name) ) … … 1223 1272 !> @date September, 2014 1224 1273 !> - force to use FillValue=1.e20 if no FillValue for coordinate variable. 1274 !> @date September, 2015 1275 !> - manage useless (dummy) attribute 1225 1276 ! 1226 1277 !> @param[in] td_file file structure … … 1250 1301 1251 1302 ! loop indices 1303 INTEGER(i4) :: ji 1252 1304 !---------------------------------------------------------------- 1253 1305 ! check if file opened … … 1275 1327 & il_natt ) 1276 1328 CALL iom_cdf__check(il_status,"IOM CDF READ VAR META: ") 1329 1277 1330 !!! fill variable dimension structure 1278 tl_dim(:)=iom_cdf__read_var_dim( td_file, il_ndim, il_dimid(:) )1331 tl_dim(:)=iom_cdf__read_var_dim( td_file, il_ndim, cl_name, il_dimid(:) ) 1279 1332 1280 1333 IF( il_natt /= 0 )THEN … … 1353 1406 & tl_att(:), id_id=id_varid ) 1354 1407 1408 !! look for dummy attribute 1409 DO ji=il_natt,1,-1 1410 IF( att_is_dummy(tl_att(ji)) )THEN 1411 CALL var_del_att(iom_cdf__read_var_meta, tl_att(ji)) 1412 ENDIF 1413 ENDDO 1414 1355 1415 ! clean 1356 1416 CALL dim_clean(tl_dim(:)) … … 1373 1433 !> So the array of dimension structure of a variable is always compose of 4 1374 1434 !> dimension (use or not). 1375 ! 1435 !> 1436 !> @warn dummy dimension are not used. 1437 !> 1376 1438 !> @author J.Paul 1377 1439 !> @date November, 2013 - Initial Version 1378 1440 !> @date July, 2015 1379 1441 !> - Bug fix: use order to disorder table (see dim_init) 1442 !> @date September, 2015 1443 !> - check dummy dimension 1380 1444 !> 1381 1445 !> @param[in] td_file file structure 1382 1446 !> @param[in] id_ndim number of dimension 1447 !> @param[in] cd_name variable name 1383 1448 !> @param[in] id_dimid array of dimension id 1384 1449 !> @return array dimension structure 1385 1450 !------------------------------------------------------------------- 1386 FUNCTION iom_cdf__read_var_dim(td_file, id_ndim, id_dimid)1451 FUNCTION iom_cdf__read_var_dim(td_file, id_ndim, cd_name, id_dimid) 1387 1452 IMPLICIT NONE 1388 1453 ! Argument 1389 1454 TYPE(TFILE), INTENT(IN) :: td_file 1390 1455 INTEGER(i4), INTENT(IN) :: id_ndim 1456 CHARACTER(LEN=*) , INTENT(IN) :: cd_name 1391 1457 INTEGER(i4), DIMENSION(:), INTENT(IN) :: id_dimid 1392 1458 … … 1401 1467 ! loop indices 1402 1468 INTEGER(i4) :: ji 1469 INTEGER(i4) :: ii 1403 1470 !---------------------------------------------------------------- 1404 1471 … … 1415 1482 CALL dim_clean(tl_dim(:)) 1416 1483 1417 ELSE IF( id_ndim > 0 .AND. id_ndim <= 4 )THEN 1418 1419 1484 ELSE IF( id_ndim > 0 )THEN 1485 1486 1487 ii=1 1420 1488 DO ji = 1, id_ndim 1421 CALL logger_debug( " IOM CDF READ VAR DIM: get variable "//& 1422 & "dimension "//TRIM(fct_str(ji)) ) 1423 1424 il_xyzt2(ji)=td_file%t_dim(id_dimid(ji))%i_xyzt2 1425 1426 ! read dimension information 1427 tl_dim(ji) = dim_init( td_file%t_dim(il_xyzt2(ji))%c_name, & 1428 & td_file%t_dim(il_xyzt2(ji))%i_len ) 1489 1490 !!! check no dummy dimension to be used 1491 IF( ANY(td_file%t_dim(:)%i_id == id_dimid(ji)) )THEN 1492 IF( ii > ip_maxdim )THEN 1493 CALL logger_error(" IOM CDF READ VAR DIM: "//& 1494 & "too much dimensions for variable "//& 1495 & TRIM(cd_name)//". check dummy configuration file.") 1496 ENDIF 1497 1498 CALL logger_debug( " IOM CDF READ VAR DIM: get variable "//& 1499 & "dimension "//TRIM(fct_str(ji)) ) 1500 1501 il_xyzt2(ii)=td_file%t_dim(id_dimid(ji))%i_xyzt2 1502 1503 ! read dimension information 1504 tl_dim(ii) = dim_init( td_file%t_dim(il_xyzt2(ii))%c_name, & 1505 & td_file%t_dim(il_xyzt2(ii))%i_len ) 1506 1507 ii=ii+1 1508 ELSE 1509 CALL logger_debug( " IOM CDF READ VAR DIM: dummy variable "//& 1510 & "dimension "//TRIM(fct_str(ji))//" not used." ) 1511 ENDIF 1429 1512 ENDDO 1430 1513 … … 1436 1519 ! clean 1437 1520 CALL dim_clean(tl_dim(:)) 1438 1439 ELSE1440 1441 CALL logger_error(" IOM CDF READ VAR DIM: can't manage "//&1442 & TRIM(fct_str(id_ndim))//" dimension(s)" )1443 1521 1444 1522 ENDIF … … 1943 2021 !> @author J.Paul 1944 2022 !> @date November, 2013 - Initial Version 2023 !> @date September, 2015 2024 !> - do not force to use zero as FillValue for any meshmask variable 1945 2025 ! 1946 2026 !> @param[inout] td_file file structure … … 1976 2056 ! check if file and variable dimension conform 1977 2057 IF( file_check_var_dim(td_file, td_var) )THEN 1978 1979 ! check variable dimension expected1980 CALL var_check_dim(td_var)1981 2058 1982 2059 ll_chg=.TRUE. … … 1998 2075 CASE('nav_lon','nav_lat', & 1999 2076 & 'glamt','glamu','glamv','glamf', & 2000 & 'gphit','gphiu','gphiv','gphif') 2077 & 'gphit','gphiu','gphiv','gphif', & 2078 & 'e1t','e1u','e1v','e1f', & 2079 & 'e2t','e2u','e2v','e2f','ff', & 2080 & 'gcost','gcosu','gcosv','gcosf', & 2081 & 'gsint','gsinu','gsinv','gsinf', & 2082 & 'mbathy','misf','isf_draft', & 2083 & 'hbatt','hbatu','hbatv','hbatf', & 2084 & 'gsigt','gsigu','gsigv','gsigf', & 2085 & 'e3t_0','e3u_0','e3v_0','e3w_0', & 2086 & 'e3f_0','gdepw_1d','gdept_1d', & 2087 & 'e3tp','e3wp','gdepw_0','rx1', & 2088 & 'gdept_0','gdepu','gdepv', & 2089 & 'hdept','hdepw','e3w_1d','e3t_1d',& 2090 & 'tmask','umask','vmask','fmask' ) 2091 ! do not change for coordinates and meshmask variables 2001 2092 END SELECT 2002 2093 ENDIF … … 2118 2209 ENDIF 2119 2210 2120 IF( tl_var%t_att(ji)%i_type == NF90_CHAR )THEN 2121 IF( TRIM(tl_var%t_att(ji)%c_value) /= '' )THEN 2122 il_status = NF90_PUT_ATT(td_file%i_id, iom_cdf__write_var_def, & 2123 & TRIM(tl_var%t_att(ji)%c_name), & 2124 & TRIM(tl_var%t_att(ji)%c_value) ) 2125 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2126 ENDIF 2127 ELSE 2128 SELECT CASE(tl_var%t_att(ji)%i_type) 2129 CASE(NF90_BYTE) 2130 il_status = NF90_PUT_ATT(td_file%i_id, & 2131 & iom_cdf__write_var_def, & 2132 & TRIM(tl_var%t_att(ji)%c_name), & 2133 & INT(tl_var%t_att(ji)%d_value(:),i1)) 2134 CASE(NF90_SHORT) 2135 il_status = NF90_PUT_ATT(td_file%i_id, & 2136 & iom_cdf__write_var_def, & 2137 & TRIM(tl_var%t_att(ji)%c_name), & 2138 & INT(tl_var%t_att(ji)%d_value(:),i2)) 2139 CASE(NF90_INT) 2140 il_status = NF90_PUT_ATT(td_file%i_id, & 2141 & iom_cdf__write_var_def, & 2142 & TRIM(tl_var%t_att(ji)%c_name), & 2143 & INT(tl_var%t_att(ji)%d_value(:),i4)) 2144 CASE(NF90_FLOAT) 2145 il_status = NF90_PUT_ATT(td_file%i_id, & 2146 & iom_cdf__write_var_def, & 2147 & TRIM(tl_var%t_att(ji)%c_name), & 2148 & REAL(tl_var%t_att(ji)%d_value(:),sp)) 2149 CASE(NF90_DOUBLE) 2150 il_status = NF90_PUT_ATT(td_file%i_id, & 2151 & iom_cdf__write_var_def, & 2152 & TRIM(tl_var%t_att(ji)%c_name), & 2153 & REAL(tl_var%t_att(ji)%d_value(:),dp)) 2154 END SELECT 2155 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2156 ENDIF 2211 SELECT CASE(tl_var%t_att(ji)%i_type) 2212 CASE(NF90_CHAR) 2213 IF( TRIM(tl_var%t_att(ji)%c_value) /= '' )THEN 2214 il_status = NF90_PUT_ATT(td_file%i_id, iom_cdf__write_var_def, & 2215 & TRIM(tl_var%t_att(ji)%c_name), & 2216 & TRIM(tl_var%t_att(ji)%c_value) ) 2217 ENDIF 2218 CASE(NF90_BYTE) 2219 il_status = NF90_PUT_ATT(td_file%i_id, & 2220 & iom_cdf__write_var_def, & 2221 & TRIM(tl_var%t_att(ji)%c_name), & 2222 & INT(tl_var%t_att(ji)%d_value(:),i1)) 2223 CASE(NF90_SHORT) 2224 il_status = NF90_PUT_ATT(td_file%i_id, & 2225 & iom_cdf__write_var_def, & 2226 & TRIM(tl_var%t_att(ji)%c_name), & 2227 & INT(tl_var%t_att(ji)%d_value(:),i2)) 2228 CASE(NF90_INT) 2229 il_status = NF90_PUT_ATT(td_file%i_id, & 2230 & iom_cdf__write_var_def, & 2231 & TRIM(tl_var%t_att(ji)%c_name), & 2232 & INT(tl_var%t_att(ji)%d_value(:),i4)) 2233 CASE(NF90_FLOAT) 2234 il_status = NF90_PUT_ATT(td_file%i_id, & 2235 & iom_cdf__write_var_def, & 2236 & TRIM(tl_var%t_att(ji)%c_name), & 2237 & REAL(tl_var%t_att(ji)%d_value(:),sp)) 2238 CASE(NF90_DOUBLE) 2239 il_status = NF90_PUT_ATT(td_file%i_id, & 2240 & iom_cdf__write_var_def, & 2241 & TRIM(tl_var%t_att(ji)%c_name), & 2242 & REAL(tl_var%t_att(ji)%d_value(:),dp)) 2243 END SELECT 2244 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR DEF: ") 2245 2157 2246 ENDDO 2158 2247 … … 2200 2289 & (td_var%d_value(:,:,:,:)-td_var%d_ofs)/td_var%d_scf 2201 2290 END WHERE 2202 2291 2203 2292 jj=0 2204 2293 DO ji = 1, ip_maxdim … … 2226 2315 2227 2316 ! put value 2228 CALL logger_ trace( &2317 CALL logger_debug( & 2229 2318 & "IOM CDF WRITE VAR VALUE: put "//TRIM(td_var%c_name)//" value "//& 2230 2319 & "in file "//TRIM(td_file%c_name)) 2231 2320 2232 2321 il_status = NF90_PUT_VAR( td_file%i_id, td_var%i_id, dl_value(:,:,:,:)) 2233 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR VALUE: ") 2322 CALL iom_cdf__check(il_status,"IOM CDF WRITE VAR VALUE ("//& 2323 & TRIM(td_var%c_name)//") :" ) 2234 2324 2235 2325 DEALLOCATE( dl_value ) -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/iom_dom.f90
r5616 r6455 234 234 CALL logger_error( & 235 235 & " IOM DOM READ VAR: there is no variable with "//& 236 & "name or standard name "//TRIM(cd_name)//&236 & "name or standard name "//TRIM(cd_name)//& 237 237 & " in processor/file "//TRIM(td_mpp%t_proc(1)%c_name)) 238 238 ENDIF -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/iom_mpp.f90
r5616 r6455 415 415 ELSE 416 416 417 CALL logger_ error( &417 CALL logger_fatal( & 418 418 & " IOM MPP READ VAR: there is no variable with "//& 419 419 & "name or standard name "//TRIM(cd_name)//& … … 648 648 DO ji=1, td_mpp%i_nproc 649 649 IF( td_mpp%t_proc(ji)%i_id /= 0 )THEN 650 !CALL file_del_att(td_mpp%t_proc(ji), 'periodicity')651 !CALL file_del_att(td_mpp%t_proc(ji), 'ew_overlap')652 653 650 CALL iom_write_file(td_mpp%t_proc(ji), cd_dimorder) 654 651 ELSE -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/iom_rstdimg.f90
r5616 r6455 395 395 !> @author J.Paul 396 396 !> @date November, 2013 - Initial Version 397 ! 397 !> @date January, 2016 398 !> - mismatch with "halo" indices 399 !> 398 400 !> @param[inout] td_file file structure 399 401 !------------------------------------------------------------------- … … 494 496 ENDIF 495 497 496 tl_att=att_init( " DOMAIN_position_first", (/il_impp(il_area), il_jmpp(il_area)/))498 tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", il_impp(:) ) 497 499 CALL file_move_att(td_file, tl_att) 498 499 tl_att=att_init( "DOMAIN_position_last", (/il_lci(il_area), il_lcj(il_area)/)) 500 tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", il_jmpp(:) ) 500 501 CALL file_move_att(td_file, tl_att) 501 502 502 tl_att=att_init( " DOMAIN_halo_size_start", (/il_ldi(il_area), il_ldj(il_area)/))503 tl_att=att_init( "SUBDOMAIN_I_dimensions", il_lci(:)) 503 504 CALL file_move_att(td_file, tl_att) 504 505 tl_att=att_init( "DOMAIN_halo_size_end", (/il_lei(il_area), il_lej(il_area)/)) 505 tl_att=att_init( "SUBDOMAIN_J_dimensions", il_lcj(:)) 506 506 CALL file_move_att(td_file, tl_att) 507 507 508 tl_att=att_init( " DOMAIN_I_position_first", il_impp(:))508 tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", il_ldi(:)) 509 509 CALL file_move_att(td_file, tl_att) 510 tl_att=att_init( " DOMAIN_J_position_first", il_jmpp(:))510 tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", il_ldj(:)) 511 511 CALL file_move_att(td_file, tl_att) 512 512 513 tl_att=att_init( " DOMAIN_I_position_last", il_lci(:))513 tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", il_lei(:)) 514 514 CALL file_move_att(td_file, tl_att) 515 tl_att=att_init( "DOMAIN_J_position_last", il_lcj(:) ) 516 CALL file_move_att(td_file, tl_att) 517 518 tl_att=att_init( "DOMAIN_I_halo_size_start", il_ldi(:) ) 519 CALL file_move_att(td_file, tl_att) 520 tl_att=att_init( "DOMAIN_J_halo_size_start", il_ldj(:) ) 521 CALL file_move_att(td_file, tl_att) 522 523 tl_att=att_init( "DOMAIN_I_halo_size_end", il_lei(:) ) 524 CALL file_move_att(td_file, tl_att) 525 tl_att=att_init( "DOMAIN_J_halo_size_end", il_lej(:) ) 515 tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", il_lej(:)) 526 516 CALL file_move_att(td_file, tl_att) 527 517 … … 1038 1028 !> @author J.Paul 1039 1029 !> @date November, 2013 - Initial Version 1030 !> @date February, 2016 1031 !> - use temporary array to read value from file 1040 1032 ! 1041 1033 !> @param[in] td_file file structure … … 1059 1051 INTEGER(i4), DIMENSION(ip_maxdim) :: il_count 1060 1052 1053 REAL(dp), DIMENSION(:,:,:) , ALLOCATABLE :: dl_tmp 1061 1054 REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value 1062 1055 … … 1142 1135 IF( ALL(td_var%t_dim(1:3)%l_use) )THEN 1143 1136 ! 3D variable (X,Y,Z) 1137 ALLOCATE(dl_tmp( td_var%t_dim(1)%i_len, & 1138 & td_var%t_dim(2)%i_len, & 1139 & td_var%t_dim(4)%i_len) ) 1144 1140 DO ji=1,td_var%t_dim(3)%i_len 1145 1141 READ(td_file%i_id, IOSTAT=il_status, REC=td_var%i_rec +ji-1) & 1146 & dl_ value(:,:,ji,:)1142 & dl_tmp(:,:,:) 1147 1143 CALL fct_err(il_status) 1148 1144 IF( il_status /= 0 )THEN … … 1150 1146 & TRIM(td_var%c_name)) 1151 1147 ENDIF 1148 dl_value(:,:,ji,:)=dl_tmp(:,:,:) 1152 1149 ENDDO 1150 DEALLOCATE(dl_tmp) 1153 1151 ELSEIF( ALL(td_var%t_dim(1:2)%l_use) )THEN 1154 1152 ! 2D variable (X,Y) … … 1427 1425 !> @author J.Paul 1428 1426 !> @date November, 2013 - Initial Version 1429 ! 1427 !> @date January, 2016 1428 !> - mismatch with "halo" indices 1429 !> 1430 1430 !> @param[inout] td_file file structure 1431 1431 !------------------------------------------------------------------- … … 1542 1542 & il_lei(il_nproc), il_lej(il_nproc) ) 1543 1543 1544 ! get domain first poistion1545 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_position_first" )1544 ! get left bottom indices 1545 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_left_bottom_indices" ) 1546 1546 il_impp(:) = 0 1547 1547 IF( il_ind /= 0 )THEN … … 1549 1549 ENDIF 1550 1550 1551 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_position_first" )1551 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_left_bottom_indices" ) 1552 1552 il_jmpp(:) = 0 1553 1553 IF( il_ind /= 0 )THEN … … 1555 1555 ENDIF 1556 1556 1557 ! check domain first poistion1557 ! check left bottom indices 1558 1558 IF( ANY(il_impp(:)==0) .OR. ANY(il_jmpp(:)==0) )THEN 1559 CALL logger_warn("WRITE FILE: no data for domain first position")1560 ENDIF 1561 1562 ! get domain last poistion1563 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_position_last" )1559 CALL logger_warn("WRITE FILE: no data for subdomain left bottom indices") 1560 ENDIF 1561 1562 ! get subdomain dimensions 1563 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_dimensions" ) 1564 1564 il_lci(:) = 0 1565 1565 IF( il_ind /= 0 )THEN … … 1567 1567 ENDIF 1568 1568 1569 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_position_last" )1569 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_dimensions" ) 1570 1570 il_lcj(:) = 0 1571 1571 IF( il_ind /= 0 )THEN … … 1573 1573 ENDIF 1574 1574 1575 ! check domain last poistion1575 ! check subdomain dimension 1576 1576 IF( ANY(il_lci(:)==0) .OR. ANY(il_lcj(:)==0) )THEN 1577 CALL logger_warn("WRITE FILE: no data for domain last position")1578 ENDIF 1579 1580 ! get halo size start1581 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_halo_size_start" )1577 CALL logger_warn("WRITE FILE: no data for subdomain dimensions") 1578 ENDIF 1579 1580 ! get first indoor indices 1581 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_first_indoor_indices" ) 1582 1582 il_ldi(:) = 0 1583 1583 IF( il_ind /= 0 )THEN … … 1585 1585 ENDIF 1586 1586 1587 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_halo_size_start" )1587 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_first_indoor_indices" ) 1588 1588 il_ldj(:) = 0 1589 1589 IF( il_ind /= 0 )THEN … … 1591 1591 ENDIF 1592 1592 1593 ! check halo size start1593 ! check first indoor indices 1594 1594 IF( ANY(il_ldi(:)==0) .OR. ANY(il_ldj(:)==0) )THEN 1595 CALL logger_warn("WRITE FILE: no data for halo size start")1596 ENDIF 1597 1598 ! get halo size end1599 il_ind=att_get_index( td_file%t_att, " DOMAIN_I_halo_size_end" )1595 CALL logger_warn("WRITE FILE: no data for subdomain first indoor indices") 1596 ENDIF 1597 1598 ! get last indoor indices 1599 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_I_last_indoor_indices" ) 1600 1600 il_lei(:) = 0 1601 1601 IF( il_ind /= 0 )THEN … … 1603 1603 ENDIF 1604 1604 1605 il_ind=att_get_index( td_file%t_att, " DOMAIN_J_halo_size_end" )1605 il_ind=att_get_index( td_file%t_att, "SUBDOMAIN_J_last_indoor_indices" ) 1606 1606 il_lej(:) = 0 1607 1607 IF( il_ind /= 0 )THEN … … 1609 1609 ENDIF 1610 1610 1611 ! check halo size end1611 ! check last indoor indices 1612 1612 IF( ANY(il_lei(:)==0) .OR. ANY(il_lej(:)==0) )THEN 1613 CALL logger_warn("WRITE FILE: no data for halo size end")1613 CALL logger_warn("WRITE FILE: no data for subdomain last indoor indices") 1614 1614 ENDIF 1615 1615 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/logger.f90
r5616 r6455 6 6 ! 7 7 ! DESCRIPTION: 8 !> @brief This module create logger file and allow to fill it depending of verbosity.8 !> @brief This module manage log file. 9 9 !> @details 10 !> This module create log file and fill it depending of verbosity. 11 !> 10 12 !> verbosity could be choosen between : 11 13 !> - trace : Most detailed information. … … 17 19 !> - error : Other runtime errors or unexpected conditions. 18 20 !> - fatal : Severe errors that cause premature termination. 19 !> default verbosity is warning20 21 !> - none : to not create and write any information in logger file.<br /> 21 ! 22 !> @warn in this case only FATAL ERROR will be detected.<br /> 23 !> 24 !> @note default verbosity is warning 25 !> 22 26 !> If total number of error exceeded maximum number 23 27 !> authorized, program stop. … … 35 39 !> @code 36 40 !> CALL logger_close() 41 !> @endcode 42 !> 43 !> to clean logger file:<br/> 44 !> @code 45 !> CALL logger_clean() 37 46 !> @endcode 38 47 !> … … 104 113 !> CALL logger_footer() 105 114 !> CALL logger_close() 115 !> CALL logger_clean() 106 116 !> @endcode 107 117 !> … … 116 126 !> CALL logger_footer() 117 127 !> CALL logger_close() 128 !> CALL logger_clean() 118 129 !> @endcode 119 130 ! … … 125 136 !> - check verbosity validity 126 137 !> - add 'none' verbosity level to not used logger file 138 !> @date January, 2016 139 !> - add logger_clean subroutine 127 140 !> 128 141 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 144 157 PUBLIC :: logger_open !< create a log file with given verbosity 145 158 PUBLIC :: logger_close !< close log file 159 PUBLIC :: logger_clean !< clean log structure 146 160 PUBLIC :: logger_header !< write header on log file 147 161 PUBLIC :: logger_footer !< write footer on log file … … 273 287 IMPLICIT NONE 274 288 ! local variable 275 INTEGER(i4) :: il_status276 !---------------------------------------------------------------- 277 IF( tm_logger%l_use )THEN 278 IF( tm_logger%i_id /= 0 )THEN 279 tm_logger%i_id = 0289 INTEGER(i4) :: il_status 290 !---------------------------------------------------------------- 291 IF( tm_logger%l_use )THEN 292 IF( tm_logger%i_id /= 0 )THEN 293 !tm_logger%i_id = 0 280 294 CLOSE( tm_logger%i_id, & 281 295 & IOSTAT=il_status) … … 289 303 290 304 END SUBROUTINE logger_close 305 !------------------------------------------------------------------- 306 !> @brief This subroutine clean a log structure. 307 !> 308 !> @author J.Paul 309 !> @date January, 2016 - Initial Version 310 !------------------------------------------------------------------- 311 SUBROUTINE logger_clean() 312 IMPLICIT NONE 313 ! local variable 314 TYPE(TLOGGER) :: tl_logger 315 !---------------------------------------------------------------- 316 tm_logger = tl_logger 317 318 END SUBROUTINE logger_clean 291 319 !------------------------------------------------------------------- 292 320 !> @brief This subroutine flushing output into log file. … … 537 565 IF( tm_logger%l_use )THEN 538 566 IF( tm_logger%i_id /= 0 )THEN 539 IF( TRIM(tm_logger%c_verb) /= 'none' )THEN 540 ! increment the error number 541 tm_logger%i_nerror=tm_logger%i_nerror+1 542 ENDIF 567 ! increment the error number 568 tm_logger%i_nerror=tm_logger%i_nerror+1 543 569 544 570 IF( INDEX(TRIM(tm_logger%c_verb),'error')/=0 )THEN … … 571 597 !> @author J.Paul 572 598 !> @date November, 2013 - Initial Version 599 !> @date September, 2015 600 !> - stop program for FATAL ERROR if verbosity is none 573 601 ! 574 602 !> @param[in] cd_msg message to write … … 598 626 CALL logger_fatal('you must have create logger to use logger_fatal') 599 627 ENDIF 628 ELSE 629 PRINT *,"FATAL ERROR :"//TRIM(cd_msg) 630 STOP 600 631 ENDIF 601 632 END SUBROUTINE logger_fatal -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/math.f90
r5616 r6455 1224 1224 1225 1225 CASE('K') 1226 1227 ALLOCATE( dl_value(il_shape(1),il_shape(2),3) ) 1226 1228 ! compute derivative in k-direction 1227 1229 DO jk=1,il_shape(3) … … 1266 1268 ENDIF 1267 1269 1268 WHERE( dl_value(:,:, 1269 & dl_value(:,:, 1270 & dl_value(:,:, 1270 WHERE( dl_value(:,:,2) /= dd_fill .AND. & ! jk 1271 & dl_value(:,:,3) /= dd_fill .AND. & ! jk+1 1272 & dl_value(:,:,1) /= dd_fill ) ! jk-1 1271 1273 1272 1274 math_deriv_3D(:,:,jk)=& -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/merge_bathy.f90
r5608 r6455 9 9 !> @file 10 10 !> @brief 11 !> This program merge bathymetry file at boundaries.11 !> This program merges bathymetry file at boundaries. 12 12 !> 13 13 !> @details 14 14 !> @section sec1 method 15 !> Coarse grid Bathymetry is interpolated on fine grid. 15 !> Coarse grid Bathymetry is interpolated on fine grid 16 !> (nearest interpolation method is used). 16 17 !> Then fine Bathymetry and refined coarse bathymetry are merged at boundaries.<br/> 17 18 !> @f[BathyFine= Weight * BathyCoarse + (1-Weight)*BathyFine@f] … … 31 32 !> you could find a template of the namelist in templates directory. 32 33 !> 33 !> merge_bathy.nam co mprise 8namelists:34 !> merge_bathy.nam contains 7 namelists: 34 35 !> - logger namelist (namlog) 35 36 !> - config namelist (namcfg) 36 37 !> - coarse grid namelist (namcrs) 37 38 !> - fine grid namelist (namfin) 38 ! >- variable namelist (namvar)39 ! - variable namelist (namvar) 39 40 !> - nesting namelist (namnst) 40 41 !> - boundary namelist (nambdy) 41 42 !> - output namelist (namout) 42 43 !> 43 !> @note44 !> All namelists have to be in file merge_bathy.nam,45 !> however variables of those namelists are all optional.46 !>47 44 !> * _logger namelist (namlog)_: 48 45 !> - cn_logfile : logger filename … … 52 49 !> 53 50 !> * _config namelist (namcfg)_: 54 !> - cn_varcfg : variable configuration file (see ./SIREN/cfg/variable.cfg) 51 !> - cn_varcfg : variable configuration file 52 !> (see ./SIREN/cfg/variable.cfg) 53 !> - cn_dumcfg : useless (dummy) configuration file, for useless 54 !> dimension or variable (see ./SIREN/cfg/dummy.cfg). 55 55 !> 56 56 !> * _coarse grid namelist (namcrs)_: … … 63 63 !> - in_perio1 : NEMO periodicity index 64 64 !> 65 ! >* _variable namelist (namvar)_:66 ! >- cn_varinfo : list of variable and extra information about request(s)67 ! >to be used (separated by ',').<br/>68 ! >each elements of *cn_varinfo* is a string character.<br/>69 ! >it is composed of the variable name follow by ':',70 ! >then request(s) to be used on this variable.<br/>71 ! >request could be:72 ! >- int = interpolation method73 ! >74 ! >requests must be separated by ';'.<br/>75 ! >order of requests does not matter.<br/>76 ! >77 ! >informations about available method could be find in78 ! >@ref interp modules.<br/>79 ! >Example: 'bathymetry: int=cubic'80 ! >@note81 ! >If you do not specify a method which is required,82 ! >default one is apply.83 ! >@warning84 ! >variable name must be __Bathymetry__ here.65 ! * _variable namelist (namvar)_: 66 ! - cn_varinfo : list of variable and extra information about request(s) 67 ! to be used (separated by ',').<br/> 68 ! each elements of *cn_varinfo* is a string character.<br/> 69 ! it is composed of the variable name follow by ':', 70 ! then request(s) to be used on this variable.<br/> 71 ! request could be: 72 ! - int = interpolation method 73 ! 74 ! requests must be separated by ';'.<br/> 75 ! order of requests does not matter.<br/> 76 ! 77 ! informations about available method could be find in 78 ! @ref interp modules.<br/> 79 ! Example: 'bathymetry: int=cubic' 80 ! @note 81 ! If you do not specify a method which is required, 82 ! default one is apply. 83 ! @warning 84 ! variable name must be __Bathymetry__ here. 85 85 !> 86 86 !> * _nesting namelist (namnst)_: … … 128 128 !> - extrapolate all land points 129 129 !> - add attributes with boundary string character (as in namelist) 130 !> @date September, 2015 131 !> - manage useless (dummy) variable, attributes, and dimension 130 132 !> 131 133 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 207 209 ! namcfg 208 210 CHARACTER(LEN=lc) :: cn_varcfg = 'variable.cfg' 211 CHARACTER(LEN=lc) :: cn_dumcfg = 'dummy.cfg' 209 212 210 213 ! namcrs … … 216 219 INTEGER(i4) :: in_perio1 = -1 217 220 218 ! namvar219 CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = ''221 ! ! namvar 222 ! CHARACTER(LEN=lc), DIMENSION(ip_maxvar) :: cn_varinfo = '' 220 223 221 224 ! namnst … … 244 247 245 248 NAMELIST /namcfg/ & !< config namelist 246 & cn_varcfg !< variable configuration file 249 & cn_varcfg, & !< variable configuration file 250 & cn_dumcfg !< dummy configuration file 247 251 248 252 NAMELIST /namcrs/ & !< coarse grid namelist … … 254 258 & in_perio1 !< periodicity index 255 259 256 NAMELIST /namvar/ & !< variable namelist257 & cn_varinfo !< list of variable and interpolation258 !< method to be used.259 !< (ex: 'votemper|linear','vosaline|cubic' )260 ! NAMELIST /namvar/ & !< variable namelist 261 ! & cn_varinfo !< list of variable and interpolation 262 ! !< method to be used. 263 ! !< (ex: 'votemper|linear','vosaline|cubic' ) 260 264 261 265 NAMELIST /namnst/ & !< nesting namelist … … 315 319 CALL var_def_extra(TRIM(cn_varcfg)) 316 320 321 ! get dummy variable 322 CALL var_get_dummy(TRIM(cn_dumcfg)) 323 ! get dummy dimension 324 CALL dim_get_dummy(TRIM(cn_dumcfg)) 325 ! get dummy attribute 326 CALL att_get_dummy(TRIM(cn_dumcfg)) 327 317 328 READ( il_fileid, NML = namcrs ) 318 329 READ( il_fileid, NML = namfin ) 319 READ( il_fileid, NML = namvar )320 ! add user change in extra information321 CALL var_chg_extra(cn_varinfo)330 ! READ( il_fileid, NML = namvar ) 331 ! ! add user change in extra information 332 ! CALL var_chg_extra(cn_varinfo) 322 333 323 334 READ( il_fileid, NML = namnst ) … … 630 641 !> @param[inout] dd_weight array of weight 631 642 !> @param[in] dd_fill fillValue 643 !> 644 !> @todo improve boundary weight function 632 645 !------------------------------------------------------------------- 633 646 SUBROUTINE merge_bathy_get_boundary( td_bathy0, td_bathy1, td_bdy, & … … 690 703 il_jmax1=td_bdy%t_seg(jl)%i_index 691 704 705 ! do not used grid point to compute 706 ! boundaries indices (cf create_boundary) 707 ! as Bathymetry always on T point 708 692 709 CASE('south') 693 710 … … 703 720 il_jmin1=td_bdy%t_seg(jl)%i_first 704 721 il_jmax1=td_bdy%t_seg(jl)%i_last 722 723 ! do not used grid point to compute 724 ! boundaries indices (cf create_boundary) 725 ! as Bathymetry always on T point 705 726 706 727 CASE('west') … … 777 798 tl_var0=iom_dom_read_var(tl_bathy0,'Bathymetry',tl_dom0) 778 799 800 ! force to use nearest interpolation 801 tl_var0%c_interp(1)='nearest' 802 779 803 ! close mpp files 780 804 CALL iom_dom_close(tl_bathy0) … … 814 838 CASE('north') 815 839 840 ! ! npoint coarse 841 ! il_width=td_bdy%t_seg(jl)%i_width-id_npoint 842 ! ! compute "distance" 843 ! dl_tmp1d(:)=(/(ji,ji=il_width-1,1,-1),(0,ji=1,id_npoint)/) 844 ! ! compute weight on segment 845 ! dl_tmp1d(:)= 0.5 + 0.5*COS( (dp_pi*dl_tmp1d(:)) / & 846 ! & (il_width) ) 847 816 848 ! compute "distance" 817 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width ,1,-1)/)849 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width-1,1,-1),0/) 818 850 819 851 ! compute weight on segment … … 831 863 832 864 ! compute "distance" 833 dl_tmp1d(:)=(/ (ji-1,ji=1,td_bdy%t_seg(jl)%i_width)/)865 dl_tmp1d(:)=(/0,(ji-1,ji=1,td_bdy%t_seg(jl)%i_width-1)/) 834 866 835 867 ! compute weight on segment … … 847 879 848 880 ! compute "distance" 849 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width ,1,-1)/)881 dl_tmp1d(:)=(/(ji-1,ji=td_bdy%t_seg(jl)%i_width-1,1,-1),0/) 850 882 851 883 ! compute weight on segment … … 863 895 864 896 ! compute "distance" 865 dl_tmp1d(:)=(/ (ji-1,ji=1,td_bdy%t_seg(jl)%i_width)/)897 dl_tmp1d(:)=(/0,(ji-1,ji=1,td_bdy%t_seg(jl)%i_width-1)/) 866 898 867 899 ! compute weight on segment -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/mpp.f90
r5616 r6455 196 196 ! REVISION HISTORY: 197 197 !> @date November, 2013 - Initial Version 198 !> @date November, 2014 - Fix memory leaks bug 198 !> @date November, 2014 199 !> - Fix memory leaks bug 200 !> @date October, 2015 201 !> - improve way to compute domain layout 202 !> @date January, 2016 203 !> - allow to print layout file (use lm_layout, hard coded) 204 !> - add mpp__compute_halo and mpp__read_halo 199 205 ! 200 206 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 214 220 215 221 ! type and variable 216 PUBLIC :: TMPP !< mpp structure 222 PUBLIC :: TMPP !< mpp structure 223 PRIVATE :: TLAY !< domain layout structure 217 224 218 225 ! function and subroutine … … 239 246 PUBLIC :: mpp_get_proc_size !< get processor domain size 240 247 241 PRIVATE :: mpp__add_proc ! add one proc strucutre in mpp structure 248 PRIVATE :: mpp__add_proc ! add proc strucutre in mpp structure 249 PRIVATE :: mpp__add_proc_unit ! add one proc strucutre in mpp structure 242 250 PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure 243 251 PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id 244 252 PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure 245 253 PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure 246 PRIVATE :: mpp__compute ! compute domain decomposition 247 PRIVATE :: mpp__del_land ! remove land sub domain from domain decomposition 254 PRIVATE :: mpp__create_layout ! create mpp structure using domain layout 248 255 PRIVATE :: mpp__optimiz ! compute optimum domain decomposition 249 PRIVATE :: mpp__land_proc ! check if processor is a land processor250 256 PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension 251 257 PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension … … 267 273 PRIVATE :: mpp__clean_unit ! clean mpp strcuture 268 274 PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture 275 PRIVATE :: mpp__compute_halo ! compute subdomain indices defined with halo 276 PRIVATE :: mpp__read_halo ! read subdomain indices defined with halo 277 278 PRIVATE :: layout__init ! initialise domain layout structure 279 PRIVATE :: layout__copy ! clean domain layout structure 280 PRIVATE :: layout__clean ! copy domain layout structure 269 281 270 282 TYPE TMPP !< mpp structure 271 272 283 ! general 273 284 CHARACTER(LEN=lc) :: c_name = '' !< base name … … 284 295 285 296 CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg) 286 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap)297 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, noextra, nooverlap) 287 298 288 299 INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp … … 290 301 291 302 TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp 292 293 303 END TYPE 304 305 TYPE TLAY !< domain layout structure 306 INTEGER(i4) :: i_niproc = 0 !< number of processors following i 307 INTEGER(i4) :: i_njproc = 0 !< number of processors following j 308 INTEGER(i4) :: i_nland = 0 !< number of land processors 309 INTEGER(i4) :: i_nsea = 0 !< number of sea processors 310 INTEGER(i4) :: i_mean = 0 !< mean sea point per proc 311 INTEGER(i4) :: i_min = 0 !< min sea point per proc 312 INTEGER(i4) :: i_max = 0 !< max sea point per proc 313 INTEGER(i4), DIMENSION(:,:), POINTER :: i_msk => NULL() !< sea/land processor mask 314 INTEGER(i4), DIMENSION(:,:), POINTER :: i_impp => NULL() !< i-indexes for mpp-subdomain left bottom 315 INTEGER(i4), DIMENSION(:,:), POINTER :: i_jmpp => NULL() !< j-indexes for mpp-subdomain left bottom 316 INTEGER(i4), DIMENSION(:,:), POINTER :: i_lci => NULL() !< i-dimensions of subdomain 317 INTEGER(i4), DIMENSION(:,:), POINTER :: i_lcj => NULL() !< j-dimensions of subdomain 318 END TYPE 319 320 ! module variable 321 INTEGER(i4) :: im_iumout = 44 322 LOGICAL :: lm_layout =.FALSE. 294 323 295 324 INTERFACE mpp_get_use 296 325 MODULE PROCEDURE mpp__get_use_unit 297 326 END INTERFACE mpp_get_use 327 328 INTERFACE mpp__add_proc 329 MODULE PROCEDURE mpp__add_proc_unit 330 END INTERFACE mpp__add_proc 298 331 299 332 INTERFACE mpp_clean … … 560 593 ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) ) 561 594 ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 595 il_proc(:,:)=-1 596 il_lci(:,:) =-1 597 il_lcj(:,:) =-1 562 598 563 599 DO jk=1,td_mpp%i_nproc 564 600 ji=td_mpp%t_proc(jk)%i_iind 565 601 jj=td_mpp%t_proc(jk)%i_jind 566 il_proc(ji,jj)=jk 602 il_proc(ji,jj)=jk-1 567 603 il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci 568 604 il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj … … 594 630 ENDIF 595 631 596 597 632 9400 FORMAT(' ***',20('*************',a3)) 598 633 9403 FORMAT(' * ',20(' * ',a3)) … … 615 650 !> @author J.Paul 616 651 !> @date November, 2013 - Initial version 652 !> @date September, 2015 653 !> - allow to define dimension with array of dimension structure 654 !> @date January, 2016 655 !> - use RESULT to rename output 656 !> - mismatch with "halo" indices 617 657 ! 618 658 !> @param[in] cd_file file name of one file composing mpp domain … … 627 667 !> @param[in] id_perio NEMO periodicity index 628 668 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 669 !> @param[in] td_dim array of dimension structure 629 670 !> @return mpp structure 630 671 !------------------------------------------------------------------- 631 TYPE(TMPP) FUNCTION mpp__init_mask(cd_file, id_mask, & 632 & id_niproc, id_njproc, id_nproc,& 633 & id_preci, id_precj, & 634 cd_type, id_ew, id_perio, id_pivot) 672 FUNCTION mpp__init_mask(cd_file, id_mask, & 673 & id_niproc, id_njproc, id_nproc, & 674 & id_preci, id_precj, & 675 & cd_type, id_ew, id_perio, id_pivot, & 676 & td_dim ) & 677 & RESULT(td_mpp) 635 678 IMPLICIT NONE 636 679 ! Argument 637 CHARACTER(LEN=*), INTENT(IN) :: cd_file 638 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 639 INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc 640 INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc 641 INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc 642 INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci 643 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 644 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 645 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 646 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 647 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 680 CHARACTER(LEN=*), INTENT(IN) :: cd_file 681 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 682 INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc 683 INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc 684 INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc 685 INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci 686 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 687 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 688 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 689 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 690 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 691 TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: td_dim 692 693 ! function 694 TYPE(TMPP) :: td_mpp 648 695 649 696 ! local variable 650 CHARACTER(LEN=lc) :: cl_type 651 652 INTEGER(i4) , DIMENSION(2) :: il_shape 653 654 TYPE(TDIM) :: tl_dim 655 656 TYPE(TATT) :: tl_att 697 CHARACTER(LEN=lc) :: cl_type 698 699 INTEGER(i4) , DIMENSION(2) :: il_shape 700 701 TYPE(TDIM) :: tl_dim 702 703 TYPE(TATT) :: tl_att 704 705 TYPE(TLAY) :: tl_lay 706 657 707 ! loop indices 658 708 INTEGER(i4) :: ji … … 660 710 661 711 ! clean mpp 662 CALL mpp_clean( mpp__init_mask)712 CALL mpp_clean(td_mpp) 663 713 664 714 ! check type … … 669 719 SELECT CASE(TRIM(cd_type)) 670 720 CASE('cdf') 671 mpp__init_mask%c_type='cdf'721 td_mpp%c_type='cdf' 672 722 CASE('dimg') 673 mpp__init_mask%c_type='dimg'723 td_mpp%c_type='dimg' 674 724 CASE DEFAULT 675 725 CALL logger_warn( "MPP INIT: type "//TRIM(cd_type)//& 676 726 & " unknown. type dimg will be used for mpp "//& 677 & TRIM( mpp__init_mask%c_name) )678 mpp__init_mask%c_type='dimg'727 & TRIM(td_mpp%c_name) ) 728 td_mpp%c_type='dimg' 679 729 END SELECT 680 730 ELSE 681 mpp__init_mask%c_type=TRIM(file_get_type(cd_file))731 td_mpp%c_type=TRIM(file_get_type(cd_file)) 682 732 ENDIF 683 733 684 734 ! get mpp name 685 mpp__init_mask%c_name=TRIM(file_rename(cd_file))735 td_mpp%c_name=TRIM(file_rename(cd_file)) 686 736 687 737 ! get global domain dimension 688 738 il_shape(:)=SHAPE(id_mask) 689 739 690 tl_dim=dim_init('X',il_shape(1)) 691 CALL mpp_add_dim(mpp__init_mask, tl_dim) 692 693 tl_dim=dim_init('Y',il_shape(2)) 694 CALL mpp_add_dim(mpp__init_mask, tl_dim) 695 696 ! clean 697 CALL dim_clean(tl_dim) 740 IF( PRESENT(td_dim) )THEN 741 DO ji=1,ip_maxdim 742 IF( td_dim(ji)%l_use )THEN 743 CALL mpp_add_dim(td_mpp, td_dim(ji)) 744 ENDIF 745 ENDDO 746 ELSE 747 tl_dim=dim_init('X',il_shape(1)) 748 CALL mpp_add_dim(td_mpp, tl_dim) 749 750 tl_dim=dim_init('Y',il_shape(2)) 751 CALL mpp_add_dim(td_mpp, tl_dim) 752 753 ! clean 754 CALL dim_clean(tl_dim) 755 ENDIF 698 756 699 757 IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. & … … 703 761 ELSE 704 762 ! get number of processors following I and J 705 IF( PRESENT(id_niproc) ) mpp__init_mask%i_niproc=id_niproc706 IF( PRESENT(id_njproc) ) mpp__init_mask%i_njproc=id_njproc763 IF( PRESENT(id_niproc) ) td_mpp%i_niproc=id_niproc 764 IF( PRESENT(id_njproc) ) td_mpp%i_njproc=id_njproc 707 765 ENDIF 708 766 709 767 ! get maximum number of processors to be used 710 IF( PRESENT(id_nproc) ) mpp__init_mask%i_nproc = id_nproc768 IF( PRESENT(id_nproc) ) td_mpp%i_nproc = id_nproc 711 769 712 770 ! get overlap region length 713 IF( PRESENT(id_preci) ) mpp__init_mask%i_preci= id_preci714 IF( PRESENT(id_precj) ) mpp__init_mask%i_precj= id_precj771 IF( PRESENT(id_preci) ) td_mpp%i_preci= id_preci 772 IF( PRESENT(id_precj) ) td_mpp%i_precj= id_precj 715 773 716 774 ! east-west overlap 717 IF( PRESENT(id_ew) ) mpp__init_mask%i_ew= id_ew775 IF( PRESENT(id_ew) ) td_mpp%i_ew= id_ew 718 776 ! NEMO periodicity 719 IF( PRESENT(id_perio) ) mpp__init_mask%i_perio= id_perio720 IF( PRESENT(id_pivot) ) mpp__init_mask%i_pivot= id_pivot721 722 IF( mpp__init_mask%i_nproc /= 0 .AND. &723 & mpp__init_mask%i_niproc /= 0 .AND. &724 & mpp__init_mask%i_njproc /= 0 .AND. &725 & mpp__init_mask%i_nproc > &726 & mpp__init_mask%i_niproc * mpp__init_mask%i_njproc )THEN777 IF( PRESENT(id_perio) ) td_mpp%i_perio= id_perio 778 IF( PRESENT(id_pivot) ) td_mpp%i_pivot= id_pivot 779 780 IF( td_mpp%i_nproc /= 0 .AND. & 781 & td_mpp%i_niproc /= 0 .AND. & 782 & td_mpp%i_njproc /= 0 .AND. & 783 & td_mpp%i_nproc > & 784 & td_mpp%i_niproc * td_mpp%i_njproc )THEN 727 785 728 786 CALL logger_error("MPP INIT: invalid domain decomposition ") 729 787 CALL logger_debug("MPP INIT: "// & 730 & TRIM(fct_str( mpp__init_mask%i_nproc))//" > "//&731 & TRIM(fct_str( mpp__init_mask%i_niproc))//" x "//&732 & TRIM(fct_str( mpp__init_mask%i_njproc)) )788 & TRIM(fct_str(td_mpp%i_nproc))//" > "//& 789 & TRIM(fct_str(td_mpp%i_niproc))//" x "//& 790 & TRIM(fct_str(td_mpp%i_njproc)) ) 733 791 734 792 ELSE 735 736 IF( mpp__init_mask%i_niproc /= 0 .AND. & 737 & mpp__init_mask%i_njproc /= 0 )THEN 738 ! compute domain decomposition 739 CALL mpp__compute( mpp__init_mask ) 740 ! remove land sub domain 741 CALL mpp__del_land( mpp__init_mask, id_mask ) 742 ELSEIF( mpp__init_mask%i_nproc /= 0 )THEN 793 IF( lm_layout )THEN 794 OPEN(im_iumout,FILE='processor.layout') 795 WRITE(im_iumout,*) 796 WRITE(im_iumout,*) ' optimisation de la partition' 797 WRITE(im_iumout,*) ' ----------------------------' 798 WRITE(im_iumout,*) 799 ENDIF 800 801 IF( td_mpp%i_niproc /= 0 .AND. & 802 & td_mpp%i_njproc /= 0 )THEN 803 ! compute domain layout 804 tl_lay=layout__init( td_mpp, id_mask, td_mpp%i_niproc, td_mpp%i_njproc ) 805 ! create mpp domain layout 806 CALL mpp__create_layout( td_mpp, tl_lay ) 807 ! clean 808 CALL layout__clean( tl_lay ) 809 ELSEIF( td_mpp%i_nproc /= 0 )THEN 743 810 ! optimiz 744 CALL mpp__optimiz( mpp__init_mask, id_mask)811 CALL mpp__optimiz( td_mpp, id_mask, td_mpp%i_nproc ) 745 812 746 813 ELSE 747 814 CALL logger_warn("MPP INIT: number of processor to be used "//& 748 815 & "not specify. force to one.") 749 mpp__init_mask%i_nproc = 1750 816 ! optimiz 751 CALL mpp__optimiz( mpp__init_mask, id_mask)817 CALL mpp__optimiz( td_mpp, id_mask, 1 ) 752 818 ENDIF 819 820 753 821 CALL logger_info("MPP INIT: domain decoposition : "//& 754 & 'niproc('//TRIM(fct_str( mpp__init_mask%i_niproc))//') * '//&755 & 'njproc('//TRIM(fct_str( mpp__init_mask%i_njproc))//') = '//&756 & 'nproc('//TRIM(fct_str( mpp__init_mask%i_nproc))//')' )822 & 'niproc('//TRIM(fct_str(td_mpp%i_niproc))//') * '//& 823 & 'njproc('//TRIM(fct_str(td_mpp%i_njproc))//') = '//& 824 & 'nproc('//TRIM(fct_str(td_mpp%i_nproc))//')' ) 757 825 758 826 ! get domain type 759 CALL mpp_get_dom( mpp__init_mask)760 761 DO ji=1, mpp__init_mask%i_nproc827 CALL mpp_get_dom( td_mpp ) 828 829 DO ji=1,td_mpp%i_nproc 762 830 763 831 ! get processor size 764 il_shape(:)=mpp_get_proc_size( mpp__init_mask, ji )832 il_shape(:)=mpp_get_proc_size( td_mpp, ji ) 765 833 766 834 tl_dim=dim_init('X',il_shape(1)) 767 CALL file_move_dim( mpp__init_mask%t_proc(ji), tl_dim)835 CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) 768 836 769 837 tl_dim=dim_init('Y',il_shape(2)) 770 CALL file_move_dim(mpp__init_mask%t_proc(ji), tl_dim) 771 838 CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) 839 840 IF( PRESENT(td_dim) )THEN 841 IF( td_dim(jp_K)%l_use )THEN 842 CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_K)) 843 ENDIF 844 IF( td_dim(jp_L)%l_use )THEN 845 CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_L)) 846 ENDIF 847 ENDIF 772 848 ! add type 773 mpp__init_mask%t_proc(ji)%c_type=TRIM(mpp__init_mask%c_type)849 td_mpp%t_proc(ji)%c_type=TRIM(td_mpp%c_type) 774 850 775 851 ! clean 776 852 CALL dim_clean(tl_dim) 853 777 854 ENDDO 778 855 779 856 ! add global attribute 780 tl_att=att_init("DOMAIN_number_total",mpp__init_mask%i_nproc) 781 CALL mpp_add_att(mpp__init_mask, tl_att) 782 783 tl_att=att_init("DOMAIN_I_number_total",mpp__init_mask%i_niproc) 784 CALL mpp_add_att(mpp__init_mask, tl_att) 785 786 tl_att=att_init("DOMAIN_J_number_total",mpp__init_mask%i_njproc) 787 CALL mpp_add_att(mpp__init_mask, tl_att) 788 789 tl_att=att_init("DOMAIN_size_global",mpp__init_mask%t_dim(1:2)%i_len) 790 CALL mpp_add_att(mpp__init_mask, tl_att) 791 792 tl_att=att_init( "DOMAIN_I_position_first", & 793 & mpp__init_mask%t_proc(:)%i_impp ) 794 CALL mpp_add_att(mpp__init_mask, tl_att) 795 796 tl_att=att_init( "DOMAIN_J_position_first", & 797 & mpp__init_mask%t_proc(:)%i_jmpp ) 798 CALL mpp_add_att(mpp__init_mask, tl_att) 799 800 tl_att=att_init( "DOMAIN_I_position_last", & 801 & mpp__init_mask%t_proc(:)%i_lci ) 802 CALL mpp_add_att(mpp__init_mask, tl_att) 803 804 tl_att=att_init( "DOMAIN_J_position_last", & 805 & mpp__init_mask%t_proc(:)%i_lcj ) 806 CALL mpp_add_att(mpp__init_mask, tl_att) 807 808 tl_att=att_init( "DOMAIN_I_halo_size_start", & 809 & mpp__init_mask%t_proc(:)%i_ldi ) 810 CALL mpp_add_att(mpp__init_mask, tl_att) 811 812 tl_att=att_init( "DOMAIN_J_halo_size_start", & 813 & mpp__init_mask%t_proc(:)%i_ldj ) 814 CALL mpp_add_att(mpp__init_mask, tl_att) 815 816 tl_att=att_init( "DOMAIN_I_halo_size_end", & 817 & mpp__init_mask%t_proc(:)%i_lei ) 818 CALL mpp_add_att(mpp__init_mask, tl_att) 819 820 tl_att=att_init( "DOMAIN_J_halo_size_end", & 821 & mpp__init_mask%t_proc(:)%i_lej ) 822 CALL mpp_add_att(mpp__init_mask, tl_att) 823 824 ! clean 825 CALL att_clean(tl_att) 857 tl_att=att_init("DOMAIN_number_total",td_mpp%i_nproc) 858 CALL mpp_add_att(td_mpp, tl_att) 859 860 tl_att=att_init("DOMAIN_LOCAL",TRIM(td_mpp%c_dom)) 861 CALL mpp_add_att(td_mpp, tl_att) 862 863 tl_att=att_init("DOMAIN_I_number_total",td_mpp%i_niproc) 864 CALL mpp_add_att(td_mpp, tl_att) 865 866 tl_att=att_init("DOMAIN_J_number_total",td_mpp%i_njproc) 867 CALL mpp_add_att(td_mpp, tl_att) 868 869 tl_att=att_init("DOMAIN_size_global",td_mpp%t_dim(1:2)%i_len) 870 CALL mpp_add_att(td_mpp, tl_att) 871 872 CALL mpp__compute_halo(td_mpp) 826 873 ENDIF 827 874 … … 880 927 il_mask(:,:,:)=var_get_mask(td_var) 881 928 929 CALL logger_info("MPP INIT: mask compute from variable "//& 930 & TRIM(td_var%c_name)) 882 931 mpp__init_var=mpp_init( cd_file, il_mask(:,:,1), & 883 932 & id_niproc, id_njproc, id_nproc,& … … 907 956 !> - DOMAIN_halo_size_end 908 957 !> or the file is assume to be no mpp file. 909 !>910 !>911 958 !> 912 959 !> @author J.Paul 913 960 !> @date November, 2013 - Initial Version 961 !> @date January, 2016 962 !> - mismatch with "halo" indices, use mpp__compute_halo 914 963 ! 915 964 !> @param[in] td_file file strcuture … … 929 978 930 979 ! local variable 931 TYPE(TMPP) :: tl_mpp 932 933 TYPE(TFILE) :: tl_file 934 935 TYPE(TDIM) :: tl_dim 936 937 TYPE(TATT) :: tl_att 938 939 INTEGER(i4) :: il_nproc 940 INTEGER(i4) :: il_attid 941 980 INTEGER(i4) :: il_nproc 981 INTEGER(i4) :: il_attid 942 982 INTEGER(i4), DIMENSION(2) :: il_shape 983 984 TYPE(TDIM) :: tl_dim 985 986 TYPE(TATT) :: tl_att 987 988 TYPE(TFILE) :: tl_file 989 990 TYPE(TMPP) :: tl_mpp 991 943 992 ! loop indices 944 993 INTEGER(i4) :: ji … … 956 1005 ! open file 957 1006 CALL iom_open(tl_file) 958 959 1007 ! read first file domain decomposition 960 1008 tl_mpp=mpp__init_file_cdf(tl_file) … … 1029 1077 CALL mpp_move_att(mpp__init_file, tl_att) 1030 1078 1031 tl_att=att_init( "DOMAIN_I_position_first", mpp__init_file%t_proc(:)%i_impp ) 1032 CALL mpp_move_att(mpp__init_file, tl_att) 1033 1034 tl_att=att_init( "DOMAIN_J_position_first", mpp__init_file%t_proc(:)%i_jmpp ) 1035 CALL mpp_move_att(mpp__init_file, tl_att) 1036 1037 tl_att=att_init( "DOMAIN_I_position_last", mpp__init_file%t_proc(:)%i_lci ) 1038 CALL mpp_move_att(mpp__init_file, tl_att) 1039 1040 tl_att=att_init( "DOMAIN_J_position_last", mpp__init_file%t_proc(:)%i_lcj ) 1041 CALL mpp_move_att(mpp__init_file, tl_att) 1042 1043 tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_file%t_proc(:)%i_ldi ) 1044 CALL mpp_move_att(mpp__init_file, tl_att) 1045 1046 tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_file%t_proc(:)%i_ldj ) 1047 CALL mpp_move_att(mpp__init_file, tl_att) 1048 1049 tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_file%t_proc(:)%i_lei ) 1050 CALL mpp_move_att(mpp__init_file, tl_att) 1051 1052 tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_file%t_proc(:)%i_lej ) 1053 CALL mpp_move_att(mpp__init_file, tl_att) 1054 1079 CALL mpp__compute_halo(mpp__init_file) 1080 1055 1081 ! clean 1056 1082 CALL mpp_clean(tl_mpp) … … 1130 1156 !> @author J.Paul 1131 1157 !> @date November, 2013 - Initial Version 1132 !> @date July, 2015 - add only use dimension in MPP structure 1158 !> @date July, 2015 1159 !> - add only use dimension in MPP structure 1160 !> @date January, 2016 1161 !> - mismatch with "halo" indices, use mpp__read_halo 1133 1162 !> 1134 1163 !> @param[in] td_file file strcuture … … 1218 1247 tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:)) 1219 1248 1220 ! DOMAIN_position_first 1221 il_attid = 0 1222 IF( ASSOCIATED(td_file%t_att) )THEN 1223 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" ) 1224 ENDIF 1225 IF( il_attid /= 0 )THEN 1226 tl_proc%i_impp = INT(td_file%t_att(il_attid)%d_value(1)) 1227 tl_proc%i_jmpp = INT(td_file%t_att(il_attid)%d_value(2)) 1228 ELSE 1229 tl_proc%i_impp = 1 1230 tl_proc%i_jmpp = 1 1231 ENDIF 1232 1233 ! DOMAIN_position_last 1234 il_attid = 0 1235 IF( ASSOCIATED(td_file%t_att) )THEN 1236 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" ) 1237 ENDIF 1238 IF( il_attid /= 0 )THEN 1239 tl_proc%i_lci = INT(td_file%t_att(il_attid)%d_value(1)) + tl_proc%i_impp 1240 tl_proc%i_lcj = INT(td_file%t_att(il_attid)%d_value(2)) + tl_proc%i_jmpp 1241 ELSE 1242 tl_proc%i_lci = mpp__init_file_cdf%t_dim(1)%i_len 1243 tl_proc%i_lcj = mpp__init_file_cdf%t_dim(2)%i_len 1244 ENDIF 1245 1246 ! DOMAIN_halo_size_start 1247 il_attid = 0 1248 IF( ASSOCIATED(td_file%t_att) )THEN 1249 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" ) 1250 ENDIF 1251 IF( il_attid /= 0 )THEN 1252 tl_proc%i_ldi = INT(td_file%t_att(il_attid)%d_value(1)) 1253 tl_proc%i_ldj = INT(td_file%t_att(il_attid)%d_value(2)) 1254 ELSE 1255 tl_proc%i_ldi = 1 1256 tl_proc%i_ldj = 1 1257 ENDIF 1258 1259 ! DOMAIN_halo_size_end 1260 il_attid = 0 1261 IF( ASSOCIATED(td_file%t_att) )THEN 1262 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" ) 1263 ENDIF 1264 IF( il_attid /= 0 )THEN 1265 tl_proc%i_lei = INT(td_file%t_att(il_attid)%d_value(1)) 1266 tl_proc%i_lej = INT(td_file%t_att(il_attid)%d_value(2)) 1267 ELSE 1268 tl_proc%i_lei = mpp__init_file_cdf%t_dim(1)%i_len 1269 tl_proc%i_lej = mpp__init_file_cdf%t_dim(2)%i_len 1270 ENDIF 1249 CALL mpp__read_halo(tl_proc, mpp__init_file_cdf%t_dim(:) ) 1271 1250 1272 1251 ! add attributes … … 1278 1257 CALL file_move_att(tl_proc, tl_att) 1279 1258 1280 tl_att=att_init( "DOMAIN_position_first", &1281 & (/tl_proc%i_impp, tl_proc%i_jmpp /) )1282 CALL file_move_att(tl_proc, tl_att)1283 1284 tl_att=att_init( "DOMAIN_position_last", &1285 & (/tl_proc%i_lci, tl_proc%i_lcj /) )1286 CALL file_move_att(tl_proc, tl_att)1287 1288 tl_att=att_init( "DOMAIN_halo_size_start", &1289 & (/tl_proc%i_ldi, tl_proc%i_ldj /) )1290 CALL file_move_att(tl_proc, tl_att)1291 1292 tl_att=att_init( "DOMAIN_halo_size_end", &1293 & (/tl_proc%i_lei, tl_proc%i_lej /) )1294 CALL file_move_att(tl_proc, tl_att)1295 1296 1259 ! add processor to mpp structure 1297 1260 CALL mpp__add_proc(mpp__init_file_cdf, tl_proc) … … 1299 1262 ! clean 1300 1263 CALL file_clean(tl_proc) 1264 CALL dim_clean(tl_dim) 1301 1265 CALL att_clean(tl_att) 1302 1266 ENDIF … … 1307 1271 & " do not exist") 1308 1272 1309 ENDIF 1273 ENDIF 1274 1310 1275 END FUNCTION mpp__init_file_cdf 1311 1276 !------------------------------------------------------------------- … … 1317 1282 !> @author J.Paul 1318 1283 !> @date November, 2013 - Initial Version 1319 ! 1284 !> @date January, 2016 1285 !> - mismatch with "halo" indices, use mpp__compute_halo 1286 !> 1320 1287 !> @param[in] td_file file strcuture 1321 1288 !> @return mpp structure … … 1336 1303 INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition 1337 1304 INTEGER(i4) :: il_area ! domain index 1305 1306 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci 1307 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi 1308 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei 1309 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp 1310 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj 1311 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj 1312 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej 1313 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp 1338 1314 1339 1315 LOGICAL :: ll_exist … … 1389 1365 ALLOCATE( mpp__init_file_rstdimg%t_proc(il_pnij) , stat=il_status ) 1390 1366 1367 ALLOCATE(il_lci (il_pnij)) 1368 ALLOCATE(il_lcj (il_pnij)) 1369 ALLOCATE(il_ldi (il_pnij)) 1370 ALLOCATE(il_ldj (il_pnij)) 1371 ALLOCATE(il_lei (il_pnij)) 1372 ALLOCATE(il_lej (il_pnij)) 1373 ALLOCATE(il_impp(il_pnij)) 1374 ALLOCATE(il_jmpp(il_pnij)) 1375 1391 1376 tl_proc=file_copy(td_file) 1392 1377 ! remove dimension from file … … 1411 1396 & il_area, & 1412 1397 & il_iglo, il_jglo, & 1413 & mpp__init_file_rstdimg%t_proc(:)%i_lci, &1414 & mpp__init_file_rstdimg%t_proc(:)%i_lcj, &1415 & mpp__init_file_rstdimg%t_proc(:)%i_ldi, &1416 & mpp__init_file_rstdimg%t_proc(:)%i_ldj, &1417 & mpp__init_file_rstdimg%t_proc(:)%i_lei, &1418 & mpp__init_file_rstdimg%t_proc(:)%i_lej, &1419 & mpp__init_file_rstdimg%t_proc(:)%i_impp, &1420 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp1398 & il_lci(1:il_pnij), & 1399 & il_lcj(1:il_pnij), & 1400 & il_ldi(1:il_pnij), & 1401 & il_ldj(1:il_pnij), & 1402 & il_lei(1:il_pnij), & 1403 & il_lej(1:il_pnij), & 1404 & il_impp(1:il_pnij), & 1405 & il_jmpp(1:il_pnij) 1421 1406 CALL fct_err(il_status) 1422 1407 IF( il_status /= 0 )THEN … … 1424 1409 & TRIM(td_file%c_name)) 1425 1410 ENDIF 1411 1412 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij) 1413 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij) 1414 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij) 1415 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij) 1416 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij) 1417 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij) 1418 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij) 1419 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_jmpp= il_jmpp(1:il_pnij) 1420 1421 DEALLOCATE(il_lci) 1422 DEALLOCATE(il_lcj) 1423 DEALLOCATE(il_ldi) 1424 DEALLOCATE(il_ldj) 1425 DEALLOCATE(il_lei) 1426 DEALLOCATE(il_lej) 1427 DEALLOCATE(il_impp) 1428 DEALLOCATE(il_jmpp) 1426 1429 1427 1430 ! global domain size … … 1435 1438 1436 1439 DO ji=1,mpp__init_file_rstdimg%i_nproc 1440 1437 1441 ! get file name 1438 1442 cl_file = file_rename(td_file%c_name,ji) … … 1445 1449 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1446 1450 1447 tl_att=att_init( "DOMAIN_position_first", &1448 & (/mpp__init_file_rstdimg%t_proc(ji)%i_impp, &1449 & mpp__init_file_rstdimg%t_proc(ji)%i_jmpp /) )1450 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1451 1452 tl_att=att_init( "DOMAIN_position_last", &1453 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lci, &1454 & mpp__init_file_rstdimg%t_proc(ji)%i_lcj /) )1455 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1456 1457 tl_att=att_init( "DOMAIN_halo_size_start", &1458 & (/mpp__init_file_rstdimg%t_proc(ji)%i_ldi, &1459 & mpp__init_file_rstdimg%t_proc(ji)%i_ldj /) )1460 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1461 1462 tl_att=att_init( "DOMAIN_halo_size_end", &1463 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lei, &1464 & mpp__init_file_rstdimg%t_proc(ji)%i_lej /) )1465 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1466 1451 ENDDO 1467 1452 … … 1486 1471 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1487 1472 1488 tl_att=att_init( "DOMAIN_I_position_first", & 1489 & mpp__init_file_rstdimg%t_proc(:)%i_impp ) 1490 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1491 1492 tl_att=att_init( "DOMAIN_J_position_first", & 1493 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp ) 1494 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1495 1496 tl_att=att_init( "DOMAIN_I_position_last", & 1497 & mpp__init_file_rstdimg%t_proc(:)%i_lci ) 1498 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1499 1500 tl_att=att_init( "DOMAIN_J_position_last", & 1501 & mpp__init_file_rstdimg%t_proc(:)%i_lcj ) 1502 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1503 1504 tl_att=att_init( "DOMAIN_I_halo_size_start", & 1505 & mpp__init_file_rstdimg%t_proc(:)%i_ldi ) 1506 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1507 1508 tl_att=att_init( "DOMAIN_J_halo_size_start", & 1509 & mpp__init_file_rstdimg%t_proc(:)%i_ldj ) 1510 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1511 1512 tl_att=att_init( "DOMAIN_I_halo_size_end", & 1513 & mpp__init_file_rstdimg%t_proc(:)%i_lei ) 1514 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1515 1516 tl_att=att_init( "DOMAIN_J_halo_size_end", & 1517 & mpp__init_file_rstdimg%t_proc(:)%i_lej ) 1518 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1473 CALL mpp_get_dom( mpp__init_file_rstdimg ) 1474 1475 CALL mpp__compute_halo( mpp__init_file_rstdimg ) 1519 1476 1520 1477 ! clean … … 1598 1555 ! Argument 1599 1556 TYPE(TMPP), INTENT(INOUT) :: td_mpp 1600 TYPE(TVAR), INTENT(IN ):: td_var1557 TYPE(TVAR), INTENT(INOUT) :: td_var 1601 1558 1602 1559 ! local variable … … 1646 1603 ! check used dimension 1647 1604 IF( mpp__check_dim(td_mpp, td_var) )THEN 1605 1606 ! check variable dimension expected 1607 CALL var_check_dim(td_var) 1648 1608 1649 1609 ! update dimension if need be … … 1915 1875 TYPE(TVAR) :: tl_var 1916 1876 !---------------------------------------------------------------- 1917 ! copy variabl e1877 ! copy variablie 1918 1878 tl_var=var_copy(td_var) 1919 1879 … … 1942 1902 !> - check proc type 1943 1903 !------------------------------------------------------------------- 1944 SUBROUTINE mpp__add_proc ( td_mpp, td_proc )1904 SUBROUTINE mpp__add_proc_unit( td_mpp, td_proc ) 1945 1905 IMPLICIT NONE 1946 1906 ! Argument … … 1957 1917 CHARACTER(LEN=lc) :: cl_name 1958 1918 !---------------------------------------------------------------- 1919 1920 ! ALLOCATE(tl_proc(1)) 1921 ! tl_proc(1)=file_copy(td_proc) 1922 ! 1923 ! CALL mpp__add_proc(td_mpp, tl_proc(:)) 1924 ! 1925 ! CALL file_clean(tl_proc(:)) 1926 ! DEALLOCATE(tl_proc) 1959 1927 1960 1928 ! check file name … … 2056 2024 2057 2025 ENDIF 2058 END SUBROUTINE mpp__add_proc 2026 2027 END SUBROUTINE mpp__add_proc_unit 2059 2028 !------------------------------------------------------------------- 2060 2029 !> @brief … … 2575 2544 !------------------------------------------------------------------- 2576 2545 !> @brief 2577 !> This subroutine compute domain decomposition for niproc and njproc 2578 !> processors following I and J. 2579 !> 2546 !> This function initialise domain layout 2547 !> 2580 2548 !> @detail 2581 !> To do so, it need to know : 2582 !> - global domain dimension 2583 !> - overlap region length 2584 !> - number of processors following I and J 2549 !> Domain layout is first compute, with domain dimension, overlap between subdomain, 2550 !> and the number of processors following I and J. 2551 !> Then the number of sea/land processors is compute with mask 2585 2552 ! 2586 2553 !> @author J.Paul 2587 !> @date November, 2013 - Initial version 2554 !> @date October, 2015 - Initial version 2555 ! 2556 !> @param[in] td_mpp mpp strcuture 2557 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2558 !> @pâram[in] id_niproc number of processors following I 2559 !> @pâram[in] id_njproc number of processors following J 2560 !> @return domain layout structure 2561 !------------------------------------------------------------------- 2562 FUNCTION layout__init( td_mpp, id_mask, id_niproc, id_njproc ) RESULT(td_lay) 2563 IMPLICIT NONE 2564 ! Argument 2565 TYPE(TMPP) , INTENT(IN) :: td_mpp 2566 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 2567 INTEGER(i4) , INTENT(IN) :: id_niproc 2568 INTEGER(i4) , INTENT(IN) :: id_njproc 2569 2570 ! function 2571 TYPE(TLAY) :: td_lay 2572 2573 ! local variable 2574 INTEGER(i4) :: ii1, ii2 2575 INTEGER(i4) :: ij1, ij2 2576 2577 INTEGER(i4) :: il_ldi 2578 INTEGER(i4) :: il_ldj 2579 INTEGER(i4) :: il_lei 2580 INTEGER(i4) :: il_lej 2581 2582 INTEGER(i4) :: il_isize !< i-direction maximum sub domain size 2583 INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size 2584 INTEGER(i4) :: il_resti !< 2585 INTEGER(i4) :: il_restj !< 2586 2587 ! loop indices 2588 INTEGER(i4) :: ji 2589 INTEGER(i4) :: jj 2590 !---------------------------------------------------------------- 2591 2592 ! intialise 2593 td_lay%i_niproc=id_niproc 2594 td_lay%i_njproc=id_njproc 2595 2596 CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//& 2597 & TRIM(fct_str(td_lay%i_niproc))//" x "//& 2598 & TRIM(fct_str(td_lay%i_njproc))//" processors") 2599 2600 ! maximum size of sub domain 2601 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_lay%i_niproc-1))/ & 2602 & td_lay%i_niproc) + 2*td_mpp%i_preci 2603 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_lay%i_njproc-1))/ & 2604 & td_lay%i_njproc) + 2*td_mpp%i_precj 2605 2606 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_lay%i_niproc) 2607 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_lay%i_njproc) 2608 IF( il_resti == 0 ) il_resti = td_lay%i_niproc 2609 IF( il_restj == 0 ) il_restj = td_lay%i_njproc 2610 2611 ! compute dimension of each sub domain 2612 ALLOCATE( td_lay%i_lci(td_lay%i_niproc,td_lay%i_njproc) ) 2613 ALLOCATE( td_lay%i_lcj(td_lay%i_niproc,td_lay%i_njproc) ) 2614 2615 td_lay%i_lci( 1 : il_resti , : ) = il_isize 2616 td_lay%i_lci( il_resti+1 : td_lay%i_niproc, : ) = il_isize-1 2617 2618 td_lay%i_lcj( : , 1 : il_restj ) = il_jsize 2619 td_lay%i_lcj( : , il_restj+1 : td_lay%i_njproc) = il_jsize-1 2620 2621 ! compute first index of each sub domain 2622 ALLOCATE( td_lay%i_impp(td_lay%i_niproc,td_lay%i_njproc) ) 2623 ALLOCATE( td_lay%i_jmpp(td_lay%i_niproc,td_lay%i_njproc) ) 2624 2625 td_lay%i_impp(:,:)=1 2626 td_lay%i_jmpp(:,:)=1 2627 2628 IF( td_lay%i_niproc > 1 )THEN 2629 DO jj=1,td_lay%i_njproc 2630 DO ji=2,td_lay%i_niproc 2631 td_lay%i_impp(ji,jj) = td_lay%i_impp(ji-1,jj) + & 2632 & td_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci 2633 ENDDO 2634 ENDDO 2635 ENDIF 2636 2637 IF( td_lay%i_njproc > 1 )THEN 2638 DO jj=2,td_lay%i_njproc 2639 DO ji=1,td_lay%i_niproc 2640 td_lay%i_jmpp(ji,jj) = td_lay%i_jmpp(ji,jj-1) + & 2641 & td_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj 2642 ENDDO 2643 ENDDO 2644 ENDIF 2645 2646 ALLOCATE(td_lay%i_msk(td_lay%i_niproc,td_lay%i_njproc)) 2647 td_lay%i_msk(:,:)=0 2648 ! init number of sea/land proc 2649 td_lay%i_nsea=0 2650 td_lay%i_nland=td_lay%i_njproc*td_lay%i_niproc 2651 2652 ! check if processor is land or sea 2653 DO jj = 1,td_lay%i_njproc 2654 DO ji = 1,td_lay%i_niproc 2655 2656 ! compute first and last indoor indices 2657 ! west boundary 2658 IF( ji == 1 )THEN 2659 il_ldi = 1 2660 ELSE 2661 il_ldi = 1 + td_mpp%i_preci 2662 ENDIF 2663 2664 ! south boundary 2665 IF( jj == 1 )THEN 2666 il_ldj = 1 2667 ELSE 2668 il_ldj = 1 + td_mpp%i_precj 2669 ENDIF 2670 2671 ! east boundary 2672 IF( ji == td_mpp%i_niproc )THEN 2673 il_lei = td_lay%i_lci(ji,jj) 2674 ELSE 2675 il_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci 2676 ENDIF 2677 2678 ! north boundary 2679 IF( jj == td_mpp%i_njproc )THEN 2680 il_lej = td_lay%i_lcj(ji,jj) 2681 ELSE 2682 il_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj 2683 ENDIF 2684 2685 ii1=td_lay%i_impp(ji,jj) + il_ldi - 1 2686 ii2=td_lay%i_impp(ji,jj) + il_lei - 1 2687 2688 ij1=td_lay%i_jmpp(ji,jj) + il_ldj - 1 2689 ij2=td_lay%i_jmpp(ji,jj) + il_lej - 1 2690 2691 td_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) ) 2692 IF( td_lay%i_msk(ji,jj) > 0 )THEN ! sea 2693 td_lay%i_nsea =td_lay%i_nsea +1 2694 td_lay%i_nland=td_lay%i_nland-1 2695 ENDIF 2696 2697 ENDDO 2698 ENDDO 2699 2700 CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(td_lay%i_nsea))) 2701 CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(td_lay%i_nland))) 2702 CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(td_lay%i_msk(:,:))))) 2703 2704 td_lay%i_mean= SUM(td_lay%i_msk(:,:)) / td_lay%i_nsea 2705 td_lay%i_min = MINVAL(td_lay%i_msk(:,:),td_lay%i_msk(:,:)/=0) 2706 td_lay%i_max = MAXVAL(td_lay%i_msk(:,:)) 2707 2708 IF( lm_layout )THEN 2709 ! print info 2710 WRITE(im_iumout,*) ' ' 2711 WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc 2712 WRITE(im_iumout,*) " jpi= ",il_isize," jpj= ",il_jsize 2713 WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj 2714 2715 2716 WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc 2717 WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea 2718 WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland 2719 WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean 2720 WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min 2721 WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max 2722 ENDIF 2723 2724 END FUNCTION layout__init 2725 !------------------------------------------------------------------- 2726 !> @brief 2727 !> This subroutine clean domain layout strcuture. 2728 !> 2729 !> @author J.Paul 2730 !> @date October, 2015 - Initial version 2731 !> 2732 !> @param[inout] td_lay domain layout strcuture 2733 !------------------------------------------------------------------- 2734 SUBROUTINE layout__clean( td_lay ) 2735 IMPLICIT NONE 2736 ! Argument 2737 TYPE(TLAY), INTENT(INOUT) :: td_lay 2738 !---------------------------------------------------------------- 2739 2740 IF( ASSOCIATED(td_lay%i_msk) )THEN 2741 DEALLOCATE(td_lay%i_msk) 2742 ENDIF 2743 IF( ASSOCIATED(td_lay%i_impp) )THEN 2744 DEALLOCATE(td_lay%i_impp) 2745 ENDIF 2746 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2747 DEALLOCATE(td_lay%i_jmpp) 2748 ENDIF 2749 IF( ASSOCIATED(td_lay%i_lci) )THEN 2750 DEALLOCATE(td_lay%i_lci) 2751 ENDIF 2752 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2753 DEALLOCATE(td_lay%i_lcj) 2754 ENDIF 2755 2756 td_lay%i_niproc=0 2757 td_lay%i_njproc=0 2758 td_lay%i_nland =0 2759 td_lay%i_nsea =0 2760 2761 td_lay%i_mean =0 2762 td_lay%i_min =0 2763 td_lay%i_max =0 2764 2765 END SUBROUTINE layout__clean 2766 !------------------------------------------------------------------- 2767 !> @brief 2768 !> This subroutine copy domain layout structure in another one. 2769 !> 2770 !> @warning do not use on the output of a function who create or read a 2771 !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). 2772 !> This will create memory leaks. 2773 !> @warning to avoid infinite loop, do not use any function inside 2774 !> this subroutine 2775 !> 2776 !> @author J.Paul 2777 !> @date October, 2015 - Initial Version 2778 ! 2779 !> @param[in] td_lay domain layout structure 2780 !> @return copy of input domain layout structure 2781 !------------------------------------------------------------------- 2782 FUNCTION layout__copy( td_lay ) 2783 IMPLICIT NONE 2784 ! Argument 2785 TYPE(TLAY), INTENT(IN) :: td_lay 2786 ! function 2787 TYPE(TLAY) :: layout__copy 2788 2789 ! local variable 2790 INTEGER(i4), DIMENSION(2) :: il_shape 2791 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp 2792 ! loop indices 2793 !---------------------------------------------------------------- 2794 2795 ! copy scalar 2796 layout__copy%i_niproc = td_lay%i_niproc 2797 layout__copy%i_njproc = td_lay%i_njproc 2798 layout__copy%i_nland = td_lay%i_nland 2799 layout__copy%i_nsea = td_lay%i_nsea 2800 layout__copy%i_mean = td_lay%i_mean 2801 layout__copy%i_min = td_lay%i_min 2802 layout__copy%i_max = td_lay%i_max 2803 2804 ! copy pointers 2805 IF( ASSOCIATED(layout__copy%i_msk) )THEN 2806 DEALLOCATE(layout__copy%i_msk) 2807 ENDIF 2808 IF( ASSOCIATED(td_lay%i_msk) )THEN 2809 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) 2810 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 2811 layout__copy%i_msk(:,:)=td_lay%i_msk(:,:) 2812 ENDIF 2813 2814 IF( ASSOCIATED(layout__copy%i_msk) ) DEALLOCATE(layout__copy%i_msk) 2815 IF( ASSOCIATED(td_lay%i_msk) )THEN 2816 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) 2817 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2818 il_tmp(:,:)=td_lay%i_msk(:,:) 2819 2820 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 2821 layout__copy%i_msk(:,:)=il_tmp(:,:) 2822 2823 DEALLOCATE(il_tmp) 2824 ENDIF 2825 2826 IF( ASSOCIATED(layout__copy%i_impp) ) DEALLOCATE(layout__copy%i_impp) 2827 IF( ASSOCIATED(td_lay%i_impp) )THEN 2828 il_shape(:)=SHAPE(td_lay%i_impp(:,:)) 2829 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2830 il_tmp(:,:)=td_lay%i_impp(:,:) 2831 2832 ALLOCATE( layout__copy%i_impp(il_shape(jp_I),il_shape(jp_J)) ) 2833 layout__copy%i_impp(:,:)=il_tmp(:,:) 2834 2835 DEALLOCATE(il_tmp) 2836 ENDIF 2837 2838 IF( ASSOCIATED(layout__copy%i_jmpp) ) DEALLOCATE(layout__copy%i_jmpp) 2839 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2840 il_shape(:)=SHAPE(td_lay%i_jmpp(:,:)) 2841 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2842 il_tmp(:,:)=td_lay%i_jmpp(:,:) 2843 2844 ALLOCATE( layout__copy%i_jmpp(il_shape(jp_I),il_shape(jp_J)) ) 2845 layout__copy%i_jmpp(:,:)=il_tmp(:,:) 2846 2847 DEALLOCATE(il_tmp) 2848 ENDIF 2849 2850 IF( ASSOCIATED(layout__copy%i_lci) ) DEALLOCATE(layout__copy%i_lci) 2851 IF( ASSOCIATED(td_lay%i_lci) )THEN 2852 il_shape(:)=SHAPE(td_lay%i_lci(:,:)) 2853 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2854 il_tmp(:,:)=td_lay%i_lci(:,:) 2855 2856 ALLOCATE( layout__copy%i_lci(il_shape(jp_I),il_shape(jp_J)) ) 2857 layout__copy%i_lci(:,:)=il_tmp(:,:) 2858 2859 DEALLOCATE(il_tmp) 2860 ENDIF 2861 2862 IF( ASSOCIATED(layout__copy%i_lcj) ) DEALLOCATE(layout__copy%i_lcj) 2863 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2864 il_shape(:)=SHAPE(td_lay%i_lcj(:,:)) 2865 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2866 il_tmp(:,:)=td_lay%i_lcj(:,:) 2867 2868 ALLOCATE( layout__copy%i_lcj(il_shape(jp_I),il_shape(jp_J)) ) 2869 layout__copy%i_lcj(:,:)=il_tmp(:,:) 2870 2871 DEALLOCATE(il_tmp) 2872 ENDIF 2873 2874 END FUNCTION layout__copy 2875 !------------------------------------------------------------------- 2876 !> @brief 2877 !> This subroutine create mpp structure using domain layout 2878 !> 2879 !> @detail 2880 ! 2881 !> @author J.Paul 2882 !> @date October, 2015 - Initial version 2588 2883 ! 2589 2884 !> @param[inout] td_mpp mpp strcuture 2590 !------------------------------------------------------------------- 2591 SUBROUTINE mpp__compute( td_mpp ) 2885 !> @param[in] td_lay domain layout structure 2886 !------------------------------------------------------------------- 2887 SUBROUTINE mpp__create_layout( td_mpp, td_lay ) 2592 2888 IMPLICIT NONE 2593 2889 ! Argument 2594 2890 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2891 TYPE(TLAY), INTENT(IN ) :: td_lay 2595 2892 2596 2893 ! local variable 2597 INTEGER(i4) :: il_isize !< i-direction maximum sub domain size2598 INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size2599 INTEGER(i4) :: il_resti !<2600 INTEGER(i4) :: il_restj !<2601 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlci2602 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlcj2603 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_impp2604 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_jmpp2605 2606 2894 CHARACTER(LEN=lc) :: cl_file 2607 2895 TYPE(TFILE) :: tl_proc … … 2617 2905 td_mpp%i_nproc=0 2618 2906 2619 CALL logger_trace( "MPP COMPUTE: compute domain decomposition with "//& 2620 & TRIM(fct_str(td_mpp%i_niproc))//" x "//& 2621 & TRIM(fct_str(td_mpp%i_njproc))//" processors") 2622 ! maximum size of sub domain 2623 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_mpp%i_niproc-1))/ & 2624 & td_mpp%i_niproc) + 2*td_mpp%i_preci 2625 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_mpp%i_njproc-1))/ & 2626 & td_mpp%i_njproc) + 2*td_mpp%i_precj 2627 2628 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_mpp%i_niproc) 2629 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_mpp%i_njproc) 2630 IF( il_resti == 0 ) il_resti = td_mpp%i_niproc 2631 IF( il_restj == 0 ) il_restj = td_mpp%i_njproc 2632 2633 ! compute dimension of each sub domain 2634 ALLOCATE( il_nlci(td_mpp%i_niproc,td_mpp%i_njproc) ) 2635 ALLOCATE( il_nlcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 2636 2637 il_nlci( 1 : il_resti , : ) = il_isize 2638 il_nlci( il_resti+1 : td_mpp%i_niproc, : ) = il_isize-1 2639 2640 il_nlcj( : , 1 : il_restj ) = il_jsize 2641 il_nlcj( : , il_restj+1 : td_mpp%i_njproc) = il_jsize-1 2642 2643 ! compute first index of each sub domain 2644 ALLOCATE( il_impp(td_mpp%i_niproc,td_mpp%i_njproc) ) 2645 ALLOCATE( il_jmpp(td_mpp%i_niproc,td_mpp%i_njproc) ) 2646 2647 il_impp(:,:)=1 2648 il_jmpp(:,:)=1 2649 2650 DO jj=1,td_mpp%i_njproc 2651 DO ji=2,td_mpp%i_niproc 2652 il_impp(ji,jj)=il_impp(ji-1,jj)+il_nlci(ji-1,jj)-2*td_mpp%i_preci 2907 CALL logger_debug( "MPP CREATE LAYOUT: create domain decomposition with "//& 2908 & TRIM(fct_str(td_lay%i_niproc))//" x "//& 2909 & TRIM(fct_str(td_lay%i_njproc))//" = "//& 2910 & TRIM(fct_str(td_lay%i_nsea))//" processors") 2911 2912 IF( lm_layout )THEN 2913 WRITE(im_iumout,*) ' choix optimum' 2914 WRITE(im_iumout,*) ' =============' 2915 WRITE(im_iumout,*) 2916 ! print info 2917 WRITE(im_iumout,*) ' ' 2918 WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc 2919 WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj 2920 2921 2922 WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc 2923 WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea 2924 WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland 2925 WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean 2926 WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min 2927 WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max 2928 ENDIF 2929 2930 td_mpp%i_niproc=td_lay%i_niproc 2931 td_mpp%i_njproc=td_lay%i_njproc 2932 !td_mpp%i_nproc =td_lay%i_nsea 2933 2934 IF( td_mpp%i_niproc*td_mpp%i_njproc == td_lay%i_nsea )THEN 2935 IF( td_lay%i_nsea == 1 )THEN 2936 td_mpp%c_dom='full' 2937 ELSE 2938 td_mpp%c_dom='nooverlap' 2939 ENDIF 2940 ELSE 2941 td_mpp%c_dom='noextra' 2942 ENDIF 2943 2944 jk=0 2945 DO jj=1,td_lay%i_njproc 2946 DO ji=1,td_lay%i_niproc 2947 2948 IF( td_lay%i_msk(ji,jj) >= 1 )THEN 2949 2950 ! get processor file name 2951 cl_file=file_rename(td_mpp%c_name,jk) 2952 ! initialise file structure 2953 tl_proc=file_init(cl_file,td_mpp%c_type) 2954 2955 ! procesor id 2956 tl_proc%i_pid=jk 2957 2958 tl_att=att_init("DOMAIN_number",tl_proc%i_pid) 2959 CALL file_add_att(tl_proc, tl_att) 2960 2961 ! processor indices 2962 tl_proc%i_iind=ji 2963 tl_proc%i_jind=jj 2964 2965 ! fill processor dimension and first indices 2966 tl_proc%i_impp = td_lay%i_impp(ji,jj) 2967 tl_proc%i_jmpp = td_lay%i_jmpp(ji,jj) 2968 2969 tl_proc%i_lci = td_lay%i_lci(ji,jj) 2970 tl_proc%i_lcj = td_lay%i_lcj(ji,jj) 2971 2972 ! compute first and last indoor indices 2973 2974 ! west boundary 2975 IF( ji == 1 )THEN 2976 tl_proc%i_ldi = 1 2977 tl_proc%l_ctr = .TRUE. 2978 ELSE 2979 tl_proc%i_ldi = 1 + td_mpp%i_preci 2980 ENDIF 2981 2982 ! south boundary 2983 IF( jj == 1 )THEN 2984 tl_proc%i_ldj = 1 2985 tl_proc%l_ctr = .TRUE. 2986 ELSE 2987 tl_proc%i_ldj = 1 + td_mpp%i_precj 2988 ENDIF 2989 2990 ! east boundary 2991 IF( ji == td_mpp%i_niproc )THEN 2992 tl_proc%i_lei = td_lay%i_lci(ji,jj) 2993 tl_proc%l_ctr = .TRUE. 2994 ELSE 2995 tl_proc%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci 2996 ENDIF 2997 2998 ! north boundary 2999 IF( jj == td_mpp%i_njproc )THEN 3000 tl_proc%i_lej = td_lay%i_lcj(ji,jj) 3001 tl_proc%l_ctr = .TRUE. 3002 ELSE 3003 tl_proc%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj 3004 ENDIF 3005 3006 ! add processor to mpp structure 3007 CALL mpp__add_proc(td_mpp, tl_proc) 3008 3009 ! clean 3010 CALL att_clean(tl_att) 3011 CALL file_clean(tl_proc) 3012 3013 ! update proc number 3014 jk=jk+1 !ji+(jj-1)*td_lay%i_niproc 3015 3016 ENDIF 2653 3017 ENDDO 2654 3018 ENDDO 2655 3019 2656 DO jj=2,td_mpp%i_njproc 2657 DO ji=1,td_mpp%i_niproc 2658 il_jmpp(ji,jj)=il_jmpp(ji,jj-1)+il_nlcj(ji,jj-1)-2*td_mpp%i_precj 2659 ENDDO 2660 ENDDO 2661 2662 DO jj=1,td_mpp%i_njproc 2663 DO ji=1,td_mpp%i_niproc 2664 2665 jk=ji+(jj-1)*td_mpp%i_niproc 2666 2667 ! get processor file name 2668 cl_file=file_rename(td_mpp%c_name,jk) 2669 ! initialise file structure 2670 tl_proc=file_init(cl_file,td_mpp%c_type) 2671 2672 ! procesor id 2673 tl_proc%i_pid=jk 2674 2675 tl_att=att_init("DOMAIN_number",tl_proc%i_pid) 2676 CALL file_add_att(tl_proc, tl_att) 2677 2678 ! processor indices 2679 tl_proc%i_iind=ji 2680 tl_proc%i_jind=jj 2681 2682 ! fill processor dimension and first indices 2683 tl_proc%i_impp = il_impp(ji,jj) 2684 tl_proc%i_jmpp = il_jmpp(ji,jj) 2685 2686 tl_att=att_init( "DOMAIN_poistion_first", & 2687 & (/tl_proc%i_impp, tl_proc%i_jmpp/) ) 2688 CALL file_add_att(tl_proc, tl_att) 2689 2690 tl_proc%i_lci = il_nlci(ji,jj) 2691 tl_proc%i_lcj = il_nlcj(ji,jj) 2692 2693 tl_att=att_init( "DOMAIN_poistion_last", & 2694 & (/tl_proc%i_lci, tl_proc%i_lcj/) ) 2695 CALL file_add_att(tl_proc, tl_att) 2696 2697 ! compute first and last indoor indices 2698 2699 ! west boundary 2700 IF( ji == 1 )THEN 2701 tl_proc%i_ldi = 1 2702 tl_proc%l_ctr = .TRUE. 2703 ELSE 2704 tl_proc%i_ldi = 1 + td_mpp%i_preci 2705 ENDIF 2706 2707 ! south boundary 2708 IF( jj == 1 )THEN 2709 tl_proc%i_ldj = 1 2710 tl_proc%l_ctr = .TRUE. 2711 ELSE 2712 tl_proc%i_ldj = 1 + td_mpp%i_precj 2713 ENDIF 2714 2715 ! east boundary 2716 IF( ji == td_mpp%i_niproc )THEN 2717 tl_proc%i_lei = il_nlci(ji,jj) 2718 tl_proc%l_ctr = .TRUE. 2719 ELSE 2720 tl_proc%i_lei = il_nlci(ji,jj) - td_mpp%i_preci 2721 ENDIF 2722 2723 ! north boundary 2724 IF( jj == td_mpp%i_njproc )THEN 2725 tl_proc%i_lej = il_nlcj(ji,jj) 2726 tl_proc%l_ctr = .TRUE. 2727 ELSE 2728 tl_proc%i_lej = il_nlcj(ji,jj) - td_mpp%i_precj 2729 ENDIF 2730 2731 tl_att=att_init( "DOMAIN_halo_size_start", & 2732 & (/tl_proc%i_ldi, tl_proc%i_ldj/) ) 2733 CALL file_add_att(tl_proc, tl_att) 2734 tl_att=att_init( "DOMAIN_halo_size_end", & 2735 & (/tl_proc%i_ldi, tl_proc%i_ldj/) ) 2736 CALL file_add_att(tl_proc, tl_att) 2737 2738 ! add processor to mpp structure 2739 CALL mpp__add_proc(td_mpp, tl_proc) 2740 2741 ! clean 2742 CALL att_clean(tl_att) 2743 CALL file_clean(tl_proc) 2744 2745 ENDDO 2746 ENDDO 2747 2748 DEALLOCATE( il_impp, il_jmpp ) 2749 DEALLOCATE( il_nlci, il_nlcj ) 2750 2751 END SUBROUTINE mpp__compute 3020 END SUBROUTINE mpp__create_layout 2752 3021 !------------------------------------------------------------------- 2753 3022 !> @brief 2754 !> This subroutine remove land processor from domain decomposition. 2755 !> 3023 !> This subroutine optimize the number of sub domain to be used, given mask. 3024 !> @details 3025 !> Actually it get the domain decomposition with the most land 3026 !> processors removed. 3027 !> If no land processor could be removed, it get the decomposition with the 3028 !> most sea processors. 3029 ! 2756 3030 !> @author J.Paul 2757 3031 !> @date November, 2013 - Initial version 2758 !> 3032 !> @date October, 2015 3033 !> - improve way to compute domain layout 3034 !> @date February, 2016 3035 !> - new criteria for domain layout in case no land proc 3036 ! 2759 3037 !> @param[inout] td_mpp mpp strcuture 2760 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2761 !------------------------------------------------------------------- 2762 SUBROUTINE mpp__del_land( td_mpp, id_mask ) 3038 !> @param[in] id_mask sub domain mask (sea=1, land=0) 3039 !> @pram[in] id_nproc maximum number of processor to be used 3040 !------------------------------------------------------------------- 3041 SUBROUTINE mpp__optimiz( td_mpp, id_mask, id_nproc ) 2763 3042 IMPLICIT NONE 2764 3043 ! Argument 2765 3044 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2766 3045 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 2767 2768 ! loop indices 2769 INTEGER(i4) :: jk 2770 !---------------------------------------------------------------- 2771 2772 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2773 jk=1 2774 DO WHILE( jk <= td_mpp%i_nproc ) 2775 IF( mpp__land_proc(td_mpp, jk, id_mask(:,:)) )THEN 2776 CALL mpp__del_proc(td_mpp, jk) 2777 ELSE 2778 jk=jk+1 2779 ENDIF 2780 ENDDO 2781 ELSE 2782 CALL logger_error("MPP DEL LAND: domain decomposition not define.") 2783 ENDIF 2784 2785 END SUBROUTINE mpp__del_land 2786 !------------------------------------------------------------------- 2787 !> @brief 2788 !> This subroutine optimize the number of sub domain to be used, given mask. 2789 !> @details 2790 !> Actually it get the domain decomposition with the most land 2791 !> processor removed. 2792 ! 2793 !> @author J.Paul 2794 !> @date November, 2013 - Initial version 2795 ! 2796 !> @param[inout] td_mpp mpp strcuture 2797 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2798 !------------------------------------------------------------------- 2799 SUBROUTINE mpp__optimiz( td_mpp, id_mask ) 2800 IMPLICIT NONE 2801 ! Argument 2802 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2803 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 3046 INTEGER(i4) , INTENT(IN) :: id_nproc 2804 3047 2805 3048 ! local variable 2806 TYPE(TMPP) :: tl_mpp 2807 INTEGER(i4) :: il_maxproc 2808 2809 TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc 3049 TYPE(TLAY) :: tl_lay 3050 TYPE(TLAY) :: tl_sav 3051 3052 REAL(dp) :: dl_min 3053 REAL(dp) :: dl_max 3054 REAL(dp) :: dl_ratio 3055 REAL(dp) :: dl_sav 3056 2810 3057 ! loop indices 2811 3058 INTEGER(i4) :: ji … … 2814 3061 2815 3062 CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition") 2816 tl_mpp=mpp_copy(td_mpp) 2817 2818 ! save maximum number of processor to be used 2819 il_maxproc=td_mpp%i_nproc 3063 dl_sav=0 2820 3064 ! 2821 td_mpp%i_nproc=0 2822 DO ji=1,il_maxproc 2823 DO jj=1,il_maxproc 2824 2825 ! clean mpp processor 2826 IF( ASSOCIATED(tl_mpp%t_proc) )THEN 2827 CALL file_clean(tl_mpp%t_proc(:)) 2828 DEALLOCATE(tl_mpp%t_proc) 2829 ENDIF 2830 2831 ! compute domain decomposition 2832 tl_mpp%i_niproc=ji 2833 tl_mpp%i_njproc=jj 2834 2835 CALL mpp__compute( tl_mpp ) 2836 2837 ! remove land sub domain 2838 CALL mpp__del_land( tl_mpp, id_mask ) 2839 2840 CALL logger_info("MPP OPTIMIZ: number of processor "//& 2841 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2842 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2843 IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. & 2844 & tl_mpp%i_nproc <= il_maxproc )THEN 2845 ! save optimiz decomposition 2846 2847 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 2848 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2849 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2850 2851 ! clean mpp 2852 CALL mpp_clean(td_mpp) 2853 2854 ! save processor array 2855 ALLOCATE( tl_proc(tl_mpp%i_nproc) ) 2856 tl_proc(:)=file_copy(tl_mpp%t_proc(:)) 2857 2858 ! remove pointer on processor array 2859 CALL file_clean(tl_mpp%t_proc(:)) 2860 DEALLOCATE(tl_mpp%t_proc) 2861 2862 ! save data except processor array 2863 td_mpp=mpp_copy(tl_mpp) 2864 2865 ! save processor array 2866 ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc) ) 2867 td_mpp%t_proc(:)=file_copy(tl_proc(:)) 2868 2869 ! clean 2870 CALL file_clean( tl_proc(:) ) 2871 DEALLOCATE(tl_proc) 2872 2873 ENDIF 2874 3065 DO ji=1,id_nproc 3066 DO jj=1,id_nproc 3067 3068 ! compute domain layout 3069 tl_lay=layout__init( td_mpp, id_mask, ji,jj ) 3070 IF( tl_lay%i_nsea <= id_nproc )THEN 3071 3072 IF( ASSOCIATED(tl_sav%i_lci) )THEN 3073 IF( tl_sav%i_nland /= 0 )THEN 3074 ! look for layout with most land proc 3075 IF( tl_lay%i_nland > tl_sav%i_nland .OR. & 3076 & ( tl_lay%i_nland == tl_sav%i_nland .AND. & 3077 & tl_lay%i_min > tl_sav%i_min ) )THEN 3078 ! save optimiz layout 3079 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 3080 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 3081 & TRIM(fct_str(tl_lay%i_nsea)) ) 3082 3083 tl_sav=layout__copy(tl_lay) 3084 ENDIF 3085 ELSE ! tl_sav%i_nland == 0 3086 ! look for layout with most sea proc 3087 ! and "square" cell 3088 dl_min=MIN(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) 3089 dl_max=MAX(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) 3090 dl_ratio=dl_min/dl_max 3091 IF( tl_lay%i_nsea > tl_sav%i_nsea .OR. & 3092 & ( tl_lay%i_nsea == tl_sav%i_nsea .AND. & 3093 & dl_ratio > dl_sav ) )THEN 3094 ! save optimiz layout 3095 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 3096 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 3097 & TRIM(fct_str(tl_lay%i_nsea)) ) 3098 3099 tl_sav=layout__copy(tl_lay) 3100 dl_sav=dl_ratio 3101 ENDIF 3102 ENDIF 3103 ELSE 3104 ! init tl_sav 3105 tl_sav=layout__copy(tl_lay) 3106 3107 dl_min=MIN(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) 3108 dl_max=MAX(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) 3109 dl_sav=dl_min/dl_max 3110 ENDIF 3111 3112 ENDIF 3113 3114 ! clean 3115 CALL layout__clean( tl_lay ) 3116 2875 3117 ENDDO 2876 3118 ENDDO 2877 3119 3120 ! create mpp domain layout 3121 CALL mpp__create_layout(td_mpp, tl_sav) 3122 2878 3123 ! clean 2879 CALL mpp_clean(tl_mpp)3124 CALL layout__clean( tl_sav ) 2880 3125 2881 3126 END SUBROUTINE mpp__optimiz 2882 !-------------------------------------------------------------------2883 !> @brief2884 !> This function check if processor is a land processor.2885 !>2886 !> @author J.Paul2887 !> @date November, 2013 - Initial version2888 !>2889 !> @param[in] td_mpp mpp strcuture2890 !> @param[in] id_proc processor id2891 !> @param[in] id_mask sub domain mask (sea=1, land=0)2892 !-------------------------------------------------------------------2893 LOGICAL FUNCTION mpp__land_proc( td_mpp , id_proc, id_mask )2894 IMPLICIT NONE2895 ! Argument2896 TYPE(TMPP), INTENT(IN) :: td_mpp2897 INTEGER(i4), INTENT(IN) :: id_proc2898 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask2899 2900 ! local variable2901 INTEGER(i4), DIMENSION(2) :: il_shape2902 !----------------------------------------------------------------2903 2904 CALL logger_trace("MPP LAND PROC: check processor "//TRIM(fct_str(id_proc))//&2905 & " of mpp "//TRIM(td_mpp%c_name) )2906 mpp__land_proc=.FALSE.2907 IF( ASSOCIATED(td_mpp%t_proc) )THEN2908 2909 il_shape(:)=SHAPE(id_mask)2910 IF( il_shape(1) /= td_mpp%t_dim(1)%i_len .OR. &2911 & il_shape(2) /= td_mpp%t_dim(2)%i_len )THEN2912 CALL logger_debug("MPP LAND PROC: mask size ("//&2913 & TRIM(fct_str(il_shape(1)))//","//&2914 & TRIM(fct_str(il_shape(2)))//")")2915 CALL logger_debug("MPP LAND PROC: domain size ("//&2916 & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&2917 & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")")2918 CALL logger_error("MPP LAND PROC: mask and domain size differ")2919 ELSE2920 IF( ALL(id_mask( td_mpp%t_proc(id_proc)%i_impp + &2921 & td_mpp%t_proc(id_proc)%i_ldi - 1 : &2922 & td_mpp%t_proc(id_proc)%i_impp + &2923 & td_mpp%t_proc(id_proc)%i_lei - 1, &2924 & td_mpp%t_proc(id_proc)%i_jmpp + &2925 & td_mpp%t_proc(id_proc)%i_ldj - 1 : &2926 & td_mpp%t_proc(id_proc)%i_jmpp + &2927 & td_mpp%t_proc(id_proc)%i_lej - 1) &2928 & /= 1 ) )THEN2929 ! land domain2930 CALL logger_info("MPP LAND PROC: processor "//TRIM(fct_str(id_proc))//&2931 & " is land processor")2932 mpp__land_proc=.TRUE.2933 ENDIF2934 ENDIF2935 2936 ELSE2937 CALL logger_error("MPP LAND PROC: domain decomposition not define.")2938 ENDIF2939 2940 END FUNCTION mpp__land_proc2941 3127 !------------------------------------------------------------------- 2942 3128 !> @brief … … 3195 3381 SELECT CASE(TRIM(td_mpp%c_dom)) 3196 3382 CASE('full') 3197 il_i1 = 1 ; il_i2 = td_mpp%t_dim(1)%i_len 3198 il_j1 = 1 ; il_j2 = td_mpp%t_dim(2)%i_len 3199 CASE('overlap') 3200 il_i1 = td_mpp%t_proc(id_procid)%i_impp 3201 il_j1 = td_mpp%t_proc(id_procid)%i_jmpp 3202 3203 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 3204 il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 3383 il_i1 = 1 3384 il_j1 = 1 3385 3386 il_i2 = td_mpp%t_dim(1)%i_len 3387 il_j2 = td_mpp%t_dim(2)%i_len 3388 CASE('noextra') 3389 il_i1 = td_mpp%t_proc(id_procid)%i_impp 3390 il_j1 = td_mpp%t_proc(id_procid)%i_jmpp 3391 3392 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 3393 il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 3205 3394 CASE('nooverlap') 3206 3395 il_i1 = td_mpp%t_proc(id_procid)%i_impp + & … … 3214 3403 & td_mpp%t_proc(id_procid)%i_lej - 1 3215 3404 CASE DEFAULT 3216 CALL logger_error("MPP GET PROC INDEX: invalid decomposition type.") 3405 CALL logger_error("MPP GET PROC INDEX: invalid "//& 3406 & "decomposition type.") 3217 3407 END SELECT 3218 3408 … … 3264 3454 il_jsize = td_mpp%t_dim(2)%i_len 3265 3455 3266 CASE(' overlap')3456 CASE('noextra') 3267 3457 3268 3458 il_isize = td_mpp%t_proc(id_procid)%i_lci … … 3308 3498 IF( ASSOCIATED(td_mpp%t_proc) )THEN 3309 3499 3310 IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_n iproc == 0 )THEN3500 IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_njproc == 0 )THEN 3311 3501 CALL logger_info("MPP GET DOM: use indoor indices to get domain "//& 3312 3502 & "decomposition type.") … … 3323 3513 & td_mpp%t_proc(1)%i_lcj ) )THEN 3324 3514 3325 td_mpp%c_dom=' overlap'3515 td_mpp%c_dom='noextra' 3326 3516 3327 3517 ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == & … … 3368 3558 td_mpp%c_dom='nooverlap' 3369 3559 ELSE 3370 td_mpp%c_dom=' overlap'3560 td_mpp%c_dom='noextra' 3371 3561 ENDIF 3372 3562 … … 3386 3576 !> @author J.Paul 3387 3577 !> @date November, 2013 - Initial Version 3578 !> @date September 2015 3579 !> - do not check used dimension here 3388 3580 !> 3389 3581 !> @param[in] td_mpp mpp structure … … 3398 3590 3399 3591 ! local variable 3592 CHARACTER(LEN=lc) :: cl_dim 3593 LOGICAL :: ll_error 3594 LOGICAL :: ll_warn 3595 3596 INTEGER(i4) :: il_ind 3400 3597 3401 3598 ! loop indices … … 3403 3600 !---------------------------------------------------------------- 3404 3601 mpp__check_var_dim=.TRUE. 3602 3405 3603 ! check used dimension 3406 IF( ANY( td_var%t_dim(:)%l_use .AND. & 3407 & td_var%t_dim(:)%i_len /= td_mpp%t_dim(:)%i_len) )THEN 3604 ll_error=.FALSE. 3605 ll_warn=.FALSE. 3606 DO ji=1,ip_maxdim 3607 il_ind=dim_get_index( td_mpp%t_dim(:), & 3608 & TRIM(td_var%t_dim(ji)%c_name), & 3609 & TRIM(td_var%t_dim(ji)%c_sname)) 3610 IF( il_ind /= 0 )THEN 3611 IF( td_var%t_dim(ji)%l_use .AND. & 3612 & td_mpp%t_dim(il_ind)%l_use .AND. & 3613 & td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN 3614 IF( INDEX( TRIM(td_var%c_axis), & 3615 & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN 3616 ll_warn=.TRUE. 3617 ELSE 3618 ll_error=.TRUE. 3619 ENDIF 3620 ENDIF 3621 ENDIF 3622 ENDDO 3623 3624 IF( ll_error )THEN 3625 3626 cl_dim='(/' 3627 DO ji = 1, td_mpp%i_ndim 3628 IF( td_mpp%t_dim(ji)%l_use )THEN 3629 cl_dim=TRIM(cl_dim)//& 3630 & TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//& 3631 & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//',' 3632 ENDIF 3633 ENDDO 3634 cl_dim=TRIM(cl_dim)//'/)' 3635 CALL logger_debug( " mpp dimension: "//TRIM(cl_dim) ) 3636 3637 cl_dim='(/' 3638 DO ji = 1, td_var%i_ndim 3639 IF( td_var%t_dim(ji)%l_use )THEN 3640 cl_dim=TRIM(cl_dim)//& 3641 & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//& 3642 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//',' 3643 ENDIF 3644 ENDDO 3645 cl_dim=TRIM(cl_dim)//'/)' 3646 CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) 3408 3647 3409 3648 mpp__check_var_dim=.FALSE. 3410 3649 3411 CALL logger_debug( &3412 & " mpp dimension: "//TRIM(fct_str(td_mpp%i_ndim))//&3413 & " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) )3414 DO ji = 1, ip_maxdim3415 CALL logger_debug( &3416 & "MPP CHECK DIM: for dimension "//&3417 & TRIM(td_mpp%t_dim(ji)%c_name)//&3418 & ", mpp length: "//&3419 & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//&3420 & ", variable length: "//&3421 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//&3422 & ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use)))3423 ENDDO3424 3425 3650 CALL logger_error( & 3426 & " MPP CHECK DIM: variable and mppdimension differ"//&3651 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3427 3652 & " for variable "//TRIM(td_var%c_name)//& 3428 & " and mpp "//TRIM(td_mpp%c_name)) 3653 & " and file "//TRIM(td_mpp%c_name)) 3654 3655 ELSEIF( ll_warn )THEN 3656 CALL logger_warn( & 3657 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3658 & " for variable "//TRIM(td_var%c_name)//& 3659 & " and file "//TRIM(td_mpp%c_name)//". you should use"//& 3660 & " var_check_dim to remove useless dimension.") 3661 ELSE 3662 3663 IF( td_var%i_ndim > td_mpp%i_ndim )THEN 3664 CALL logger_info("MPP CHECK VAR DIM: variable "//& 3665 & TRIM(td_var%c_name)//" use more dimension than file "//& 3666 & TRIM(td_mpp%c_name)//" do until now.") 3667 ENDIF 3429 3668 3430 3669 ENDIF … … 3583 3822 ENDIF 3584 3823 END FUNCTION mpp_recombine_var 3824 !------------------------------------------------------------------- 3825 !> @brief This subroutine read subdomain indices defined with halo 3826 !> (NEMO netcdf way) 3827 !> 3828 !> @author J.Paul 3829 !> @date January, 2016 - Initial Version 3830 !> 3831 !> @param[inout] td_file mpp structure 3832 !------------------------------------------------------------------- 3833 SUBROUTINE mpp__read_halo(td_file, td_dimglo) 3834 IMPLICIT NONE 3835 ! Argument 3836 TYPE(TFILE) , INTENT(INOUT) :: td_file 3837 TYPE(TDIM) , DIMENSION(:), INTENT(IN ) :: td_dimglo 3838 3839 ! local variable 3840 INTEGER(i4) :: il_attid 3841 INTEGER(i4) :: il_ifirst 3842 INTEGER(i4) :: il_jfirst 3843 INTEGER(i4) :: il_ilast 3844 INTEGER(i4) :: il_jlast 3845 INTEGER(i4) :: il_ihalostart 3846 INTEGER(i4) :: il_jhalostart 3847 INTEGER(i4) :: il_ihaloend 3848 INTEGER(i4) :: il_jhaloend 3849 3850 CHARACTER(LEN=lc) :: cl_dom 3851 !---------------------------------------------------------------- 3852 3853 ! DOMAIN_position_first 3854 il_attid = 0 3855 IF( ASSOCIATED(td_file%t_att) )THEN 3856 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" ) 3857 ENDIF 3858 IF( il_attid /= 0 )THEN 3859 il_ifirst = INT(td_file%t_att(il_attid)%d_value(1)) 3860 il_jfirst = INT(td_file%t_att(il_attid)%d_value(2)) 3861 ELSE 3862 il_ifirst = 1 3863 il_jfirst = 1 3864 ENDIF 3865 3866 ! DOMAIN_position_last 3867 il_attid = 0 3868 IF( ASSOCIATED(td_file%t_att) )THEN 3869 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" ) 3870 ENDIF 3871 IF( il_attid /= 0 )THEN 3872 il_ilast = INT(td_file%t_att(il_attid)%d_value(1)) 3873 il_jlast = INT(td_file%t_att(il_attid)%d_value(2)) 3874 ELSE 3875 il_ilast = td_file%t_dim(1)%i_len 3876 il_jlast = td_file%t_dim(2)%i_len 3877 ENDIF 3878 3879 ! DOMAIN_halo_size_start 3880 il_attid = 0 3881 IF( ASSOCIATED(td_file%t_att) )THEN 3882 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" ) 3883 ENDIF 3884 IF( il_attid /= 0 )THEN 3885 il_ihalostart = INT(td_file%t_att(il_attid)%d_value(1)) 3886 il_jhalostart = INT(td_file%t_att(il_attid)%d_value(2)) 3887 ELSE 3888 il_ihalostart = 0 3889 il_jhalostart = 0 3890 ENDIF 3891 3892 ! DOMAIN_halo_size_end 3893 il_attid = 0 3894 IF( ASSOCIATED(td_file%t_att) )THEN 3895 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" ) 3896 ENDIF 3897 IF( il_attid /= 0 )THEN 3898 il_ihaloend = INT(td_file%t_att(il_attid)%d_value(1)) 3899 il_jhaloend = INT(td_file%t_att(il_attid)%d_value(2)) 3900 ELSE 3901 il_ihaloend = 0 3902 il_jhaloend = 0 3903 ENDIF 3904 3905 IF( (td_dimglo(jp_I)%i_len == td_file%t_dim(jp_I)%i_len) .AND. & 3906 & (td_dimglo(jp_J)%i_len == td_file%t_dim(jp_J)%i_len) )THEN 3907 cl_dom='full' 3908 ELSEIF( il_ihalostart == 0 .AND. il_jhalostart == 0 .AND. & 3909 & il_ihaloend == 0 .AND. il_jhaloend == 0 )THEN 3910 cl_dom='nooverlap' 3911 ELSE 3912 cl_dom='noextra' 3913 ENDIF 3914 3915 SELECT CASE(TRIM(cl_dom)) 3916 CASE('full') 3917 td_file%i_impp = il_ifirst 3918 td_file%i_jmpp = il_jfirst 3919 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3920 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3921 td_file%i_ldi = il_ihalostart + 1 3922 td_file%i_ldj = il_jhalostart + 1 3923 td_file%i_lei = td_file%t_dim(jp_I)%i_len - il_ihaloend 3924 td_file%i_lej = td_file%t_dim(jp_J)%i_len - il_jhaloend 3925 CASE('noextra') 3926 td_file%i_impp = il_ifirst 3927 td_file%i_jmpp = il_jfirst 3928 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3929 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3930 td_file%i_ldi = il_ihalostart + 1 3931 td_file%i_ldj = il_jhalostart + 1 3932 td_file%i_lei = td_file%i_lci - il_ihaloend 3933 td_file%i_lej = td_file%i_lcj - il_jhaloend 3934 CASE('nooverlap') !!!????? 3935 td_file%i_impp = il_ifirst 3936 td_file%i_jmpp = il_jfirst 3937 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3938 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3939 td_file%i_ldi = 1 3940 td_file%i_ldj = 1 3941 td_file%i_lei = td_file%t_dim(jp_I)%i_len 3942 td_file%i_lej = td_file%t_dim(jp_J)%i_len 3943 END SELECT 3944 3945 END SUBROUTINE mpp__read_halo 3946 !------------------------------------------------------------------- 3947 !> @brief This subroutine compute subdomain indices defined with halo 3948 !> (NEMO netcdf way) 3949 !> 3950 !> @author J.Paul 3951 !> @date January, 2016 - Initial Version 3952 !> 3953 !> @param[inout] td_mpp mpp structure 3954 !------------------------------------------------------------------- 3955 SUBROUTINE mpp__compute_halo(td_mpp) 3956 IMPLICIT NONE 3957 ! Argument 3958 TYPE(TMPP) , INTENT(INOUT) :: td_mpp 3959 3960 ! local variable 3961 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ifirst 3962 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jfirst 3963 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ilast 3964 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jlast 3965 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihalostart 3966 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhalostart 3967 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihaloend 3968 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhaloend 3969 3970 TYPE(TATT) :: tl_att 3971 3972 ! loop indices 3973 INTEGER(i4) :: ji 3974 !---------------------------------------------------------------- 3975 3976 ALLOCATE( il_ifirst (td_mpp%i_nproc) ) 3977 ALLOCATE( il_jfirst (td_mpp%i_nproc) ) 3978 3979 ALLOCATE( il_ilast (td_mpp%i_nproc) ) 3980 ALLOCATE( il_jlast (td_mpp%i_nproc) ) 3981 3982 ALLOCATE( il_ihalostart(td_mpp%i_nproc) ) 3983 ALLOCATE( il_jhalostart(td_mpp%i_nproc) ) 3984 3985 ALLOCATE( il_ihaloend (td_mpp%i_nproc) ) 3986 ALLOCATE( il_jhaloend (td_mpp%i_nproc) ) 3987 3988 SELECT CASE(TRIM(td_mpp%c_dom)) 3989 CASE('full') 3990 3991 il_ifirst(:)=td_mpp%t_proc(:)%i_impp 3992 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp 3993 3994 il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%t_dim(jp_I)%i_len - 1 3995 il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%t_dim(jp_J)%i_len - 1 3996 3997 il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 3998 il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 3999 4000 il_ihaloend(:)=td_mpp%t_proc(:)%t_dim(jp_I)%i_len - td_mpp%t_proc(:)%i_lei 4001 il_jhaloend(:)=td_mpp%t_proc(:)%t_dim(jp_J)%i_len - td_mpp%t_proc(:)%i_lej 4002 4003 CASE('noextra') 4004 4005 il_ifirst(:)=td_mpp%t_proc(:)%i_impp 4006 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp 4007 4008 il_ilast(:) =td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lci - 1 4009 il_jlast(:) =td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lcj - 1 4010 4011 il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 4012 il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 4013 4014 il_ihaloend(:)=td_mpp%t_proc(:)%i_lci - td_mpp%t_proc(:)%i_lei 4015 il_jhaloend(:)=td_mpp%t_proc(:)%i_lcj - td_mpp%t_proc(:)%i_lej 4016 4017 CASE('nooverlap') 4018 4019 il_ifirst(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_ldi - 1 4020 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_ldj - 1 4021 4022 il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lei - 1 4023 il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lej - 1 4024 4025 il_ihalostart(:)=0 4026 il_jhalostart(:)=0 4027 4028 il_ihaloend(:)=0 4029 il_jhaloend(:)=0 4030 4031 CASE DEFAULT 4032 CALL logger_fatal("MPP INIT: invalid "//& 4033 & "decomposition type.") 4034 END SELECT 4035 4036 DO ji=1,td_mpp%i_nproc 4037 tl_att=att_init( "DOMAIN_position_first", & 4038 & (/ il_ifirst(ji), il_jfirst(ji) /) ) 4039 CALL file_move_att(td_mpp%t_proc(ji), tl_att) 4040 4041 tl_att=att_init( "DOMAIN_position_last", & 4042 & (/ il_ilast(ji), il_jlast(ji) /) ) 4043 CALL file_move_att(td_mpp%t_proc(ji), tl_att) 4044 4045 tl_att=att_init( "DOMAIN_halo_size_start", & 4046 & (/ il_ihalostart(ji), il_jhalostart(ji) /) ) 4047 CALL file_move_att( td_mpp%t_proc(ji), tl_att) 4048 4049 tl_att=att_init( "DOMAIN_halo_size_end", & 4050 & (/ il_ihaloend(ji), il_jhaloend(ji) /) ) 4051 CALL file_move_att( td_mpp%t_proc(ji), tl_att) 4052 ENDDO 4053 4054 DEALLOCATE( il_ifirst ) 4055 DEALLOCATE( il_jfirst ) 4056 4057 DEALLOCATE( il_ilast ) 4058 DEALLOCATE( il_jlast ) 4059 4060 DEALLOCATE( il_ihalostart) 4061 DEALLOCATE( il_jhalostart) 4062 4063 DEALLOCATE( il_ihaloend ) 4064 DEALLOCATE( il_jhaloend ) 4065 4066 !impp 4067 tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", td_mpp%t_proc(:)%i_impp) 4068 CALL mpp_move_att(td_mpp, tl_att) 4069 4070 tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", td_mpp%t_proc(:)%i_jmpp) 4071 CALL mpp_move_att(td_mpp, tl_att) 4072 4073 ! lci 4074 tl_att=att_init( "SUBDOMAIN_I_dimensions", td_mpp%t_proc(:)%i_lci) 4075 CALL mpp_move_att(td_mpp, tl_att) 4076 4077 tl_att=att_init( "SUBDOMAIN_J_dimensions", td_mpp%t_proc(:)%i_lcj) 4078 CALL mpp_move_att(td_mpp, tl_att) 4079 4080 ! ldi 4081 tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", td_mpp%t_proc(:)%i_ldi) 4082 CALL mpp_move_att(td_mpp, tl_att) 4083 4084 tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", td_mpp%t_proc(:)%i_ldj) 4085 CALL mpp_move_att(td_mpp, tl_att) 4086 4087 ! lei 4088 tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", td_mpp%t_proc(:)%i_lei) 4089 CALL mpp_move_att(td_mpp, tl_att) 4090 4091 tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", td_mpp%t_proc(:)%i_lej) 4092 CALL mpp_move_att(td_mpp, tl_att) 4093 4094 ! clean 4095 CALL att_clean(tl_att) 4096 4097 END SUBROUTINE mpp__compute_halo 3585 4098 END MODULE mpp 3586 4099 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/multi.f90
r5616 r6455 173 173 !> @date July, 2015 174 174 !> - check if variable to be read is in file 175 !> @date January, 2016 176 !> - read variable dimensions 175 177 !> 176 178 !> @param[in] cd_varfile variable location information (from namelist) … … 187 189 188 190 ! local variable 189 CHARACTER(LEN=lc) :: cl_name 190 CHARACTER(LEN=lc) :: cl_lower 191 CHARACTER(LEN=lc) :: cl_file 192 CHARACTER(LEN=lc) :: cl_matrix 193 194 INTEGER(i4) :: il_nvar 195 INTEGER(i4) :: il_varid 196 197 LOGICAL :: ll_dim 198 199 TYPE(TVAR) :: tl_var 200 201 TYPE(TMPP) :: tl_mpp 191 CHARACTER(LEN=lc) :: cl_name 192 CHARACTER(LEN=lc) :: cl_lower 193 CHARACTER(LEN=lc) :: cl_file 194 CHARACTER(LEN=lc) :: cl_matrix 195 196 INTEGER(i4) :: il_nvar 197 INTEGER(i4) :: il_varid 198 199 LOGICAL :: ll_dim 200 201 TYPE(TDIM), DIMENSION(ip_maxdim) :: tl_dim 202 203 TYPE(TVAR) :: tl_var 204 205 TYPE(TMPP) :: tl_mpp 202 206 203 207 ! loop indices … … 216 220 217 221 IF( LEN(TRIM(cl_file)) == lc )THEN 218 CALL logger_fatal("MULTI INIT: file name too long ( ==256)."//&219 & "check namelist.")222 CALL logger_fatal("MULTI INIT: file name too long (>"//& 223 & TRIM(fct_str(lc))//"). check namelist.") 220 224 ENDIF 221 225 … … 243 247 ! 244 248 tl_mpp=mpp_init( file_init(TRIM(cl_file)) ) 245 246 249 ! define variable 247 250 IF( TRIM(fct_lower(cl_lower)) /= 'all' )THEN … … 255 258 ENDIF 256 259 257 ! clean var 260 ! get (global) variable dimension 261 tl_dim(jp_I)=dim_copy(tl_mpp%t_dim(jp_I)) 262 tl_dim(jp_J)=dim_copy(tl_mpp%t_dim(jp_J)) 263 tl_dim(jp_K)=dim_copy(tl_mpp%t_proc(1)%t_var(il_varid)%t_dim(jp_K)) 264 tl_dim(jp_L)=dim_copy(tl_mpp%t_proc(1)%t_var(il_varid)%t_dim(jp_L)) 265 266 ! clean all varible 258 267 CALL mpp_del_var(tl_mpp) 259 268 260 tl_var=var_init(TRIM(cl_lower) )269 tl_var=var_init(TRIM(cl_lower), td_dim=tl_dim(:)) 261 270 262 271 ! add variable … … 272 281 273 282 DO jk=tl_mpp%t_proc(1)%i_nvar,1,-1 274 283 275 284 ! check if variable is dimension 276 285 ll_dim=.FALSE. … … 379 388 ! print file 380 389 IF( td_multi%i_nmpp /= 0 .AND. ASSOCIATED(td_multi%t_mpp) )THEN 381 WRITE(*,'(/a,i3)') 'MULTI: total number of mpp: ',&390 WRITE(*,'(/a,i3)') 'MULTI: total number of file(s): ',& 382 391 & td_multi%i_nmpp 383 WRITE(*,'(6x,a,i3)') ' total number of variable : ',&392 WRITE(*,'(6x,a,i3)') ' total number of variable(s): ',& 384 393 & td_multi%i_nvar 385 394 DO ji=1,td_multi%i_nmpp 386 WRITE(*,'(3x,3a)') ' MPPFILE ',TRIM(td_multi%t_mpp(ji)%c_name),&395 WRITE(*,'(3x,3a)') 'FILE ',TRIM(td_multi%t_mpp(ji)%c_name),& 387 396 & ' CONTAINS' 388 397 DO jj=1,td_multi%t_mpp(ji)%t_proc(1)%i_nvar -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/phycst.f90
r5608 r6455 12 12 ! REVISION HISTORY: 13 13 !> @date November, 2013 - Initial Version 14 !> @date September, 2015 15 !> - add physical constant to compute meshmask 14 16 ! 15 17 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 23 25 PUBLIC :: dp_pi !< pi 24 26 PUBLIC :: dp_eps !< epsilon value 25 PUBLIC :: dp_rearth !< earth radius (km)27 PUBLIC :: dp_rearth !< earth radius [m] 26 28 PUBLIC :: dp_deg2rad !< degree to radian ratio 27 29 PUBLIC :: dp_rad2deg !< radian to degree ratio 28 30 PUBLIC :: dp_delta !< 31 PUBLIC :: dp_omega !< earth rotation parameter [s-1] 32 PUBLIC :: dp_day !< day [s] 33 PUBLIC :: dp_siyea !< sideral year [s] 34 PUBLIC :: dp_siday !< sideral day [s] 35 36 REAL(wp), PUBLIC :: rday = 24.*60.*60. !: day [s] 37 REAL(wp), PUBLIC :: rsiyea !: sideral year [s] 38 REAL(wp), PUBLIC :: rsiday !: sideral day [s] 29 39 30 40 REAL(dp), PARAMETER :: dp_pi = 3.14159274101257_dp 31 41 REAL(dp), PARAMETER :: dp_eps = EPSILON(1._dp) 32 REAL(dp), PARAMETER :: dp_rearth = 6 871._dp42 REAL(dp), PARAMETER :: dp_rearth = 6371229._dp 33 43 REAL(dp), PARAMETER :: dp_deg2rad = dp_pi/180.0 34 44 REAL(dp), PARAMETER :: dp_rad2deg = 180.0/dp_pi 35 45 46 REAL(dp), PARAMETER :: dp_day = 24.*60.*60. 47 REAL(dp), PARAMETER :: dp_siyea = 365.25_wp * dp_day * & 48 & 2._wp * dp_pi / 6.283076_dp 49 REAL(dp), PARAMETER :: dp_siday = dp_day / ( 1._wp + dp_day / dp_siyea ) 50 36 51 REAL(dp), PARAMETER :: dp_delta=1.e-6 52 REAL(dp), PARAMETER :: dp_omega= 2._dp * dp_pi / dp_siday 37 53 END MODULE phycst 38 54 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/variable.f90
r5616 r6455 285 285 !> @date July, 2015 286 286 !> - add subroutine var_chg_unit to change unit of output variable 287 !> @date Spetember, 2015 288 !> - manage useless (dummy) variable 287 289 ! 288 290 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 305 307 306 308 PUBLIC :: tg_varextra !< array of variable structure with extra information. 309 310 PRIVATE :: cm_dumvar !< dummy variable array 307 311 308 312 ! function and subroutine … … 334 338 PUBLIC :: var_chg_extra !< read variable namelist information, and modify extra information. 335 339 PUBLIC :: var_check_dim !< check variable dimension expected 340 PUBLIC :: var_get_dummy !< fill dummy variable array 341 PUBLIC :: var_is_dummy !< check if variable is defined as dummy variable 336 342 337 343 PRIVATE :: var__init ! initialize variable structure without array of value … … 445 451 !< fill when running var_def_extra() 446 452 453 CHARACTER(LEN=lc), DIMENSION(ip_maxdum), SAVE :: cm_dumvar !< dummy variable 454 447 455 INTERFACE var_init 448 456 MODULE PROCEDURE var__init ! initialize variable structure without array of value … … 6698 6706 !> given variable name or standard name. 6699 6707 !> 6700 !> @warning only variable read from file, have an id.6701 !>6702 6708 !> @author J.Paul 6703 6709 !> @date November, 2013 - Initial Version 6710 !> @date July, 2015 6711 !> - check long name 6704 6712 ! 6705 6713 !> @param[in] td_var array of variable structure … … 6735 6743 ELSE IF( fct_lower(td_var(ji)%c_stdname) == fct_lower(cd_name) .AND.& 6736 6744 & TRIM(fct_lower(td_var(ji)%c_stdname)) /= '' )THEN 6745 6746 var_get_id=td_var(ji)%i_id 6747 EXIT 6748 6749 ! look for variable long name 6750 ELSE IF( fct_lower(td_var(ji)%c_longname) == fct_lower(cd_name) .AND.& 6751 & TRIM(fct_lower(td_var(ji)%c_longname)) /= '' )THEN 6737 6752 6738 6753 var_get_id=td_var(ji)%i_id … … 6775 6790 IF( ASSOCIATED(td_var%d_value) )THEN 6776 6791 6777 CALL logger_trace( "VAR GET MASK: create mask from variable "//& 6778 & TRIM(td_var%c_name) ) 6792 CALL logger_debug( "VAR GET MASK: create mask from variable "//& 6793 & TRIM(td_var%c_name)//", FillValue ="//& 6794 & TRIM(fct_str(td_var%d_fill))) 6779 6795 var_get_mask(:,:,:)=1 6780 6796 WHERE( td_var%d_value(:,:,:,1) == td_var%d_fill ) … … 7279 7295 7280 7296 ! local variable 7297 CHARACTER(LEN=lc) :: cl_tmp 7298 7281 7299 INTEGER(i4) :: il_ind 7300 7282 7301 TYPE(TATT) :: tl_att 7283 7302 7284 7303 ! loop indices 7304 INTEGER(i4) :: ji 7285 7305 !---------------------------------------------------------------- 7286 7306 … … 7335 7355 td_var%c_axis=TRIM(tg_varextra(il_ind)%c_axis) 7336 7356 ! create attibute 7337 tl_att=att_init('axis',TRIM(td_var%c_axis)) 7338 CALL var_move_att(td_var, tl_att) 7357 IF( TRIM(fct_upper(td_var%c_name)) == TRIM(td_var%c_axis) )THEN 7358 tl_att=att_init('axis',TRIM(td_var%c_axis)) 7359 ELSE 7360 cl_tmp="" 7361 DO ji=LEN(TRIM(td_var%c_axis)),1,-1 7362 cl_tmp=TRIM(cl_tmp)//" "//TRIM(td_var%c_axis(ji:ji)) 7363 ENDDO 7364 tl_att=att_init('associate',TRIM(ADJUSTL(cl_tmp))) 7365 ENDIF 7366 CALL var_move_att(td_var, tl_att) 7339 7367 ENDIF 7340 7368 … … 7402 7430 ENDIF 7403 7431 7432 ELSE 7433 CALL logger_warn("VAR GET EXTRA: no extra information on "//& 7434 & "variable "//TRIM(td_var%c_name)//". you should define it"//& 7435 & " (see variable.cfg).") 7404 7436 ENDIF 7405 7437 … … 7425 7457 !> - change way to get information in namelist, 7426 7458 !> value follows string "min =" 7459 !> @date Feb, 2016 7460 !> - check character just after keyword 7427 7461 ! 7428 7462 !> @param[in] cd_name variable name … … 7447 7481 ! loop indices 7448 7482 INTEGER(i4) :: ji 7483 INTEGER(i4) :: jj 7449 7484 !---------------------------------------------------------------- 7450 7485 ! init … … 7457 7492 il_ind=INDEX(TRIM(cl_tmp),'min') 7458 7493 IF( il_ind /= 0 )THEN 7459 cl_min=fct_split(cl_tmp,2,'=') 7460 EXIT 7494 ! check character just after 7495 jj=il_ind+LEN('min') 7496 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7497 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7498 cl_min=fct_split(cl_tmp,2,'=') 7499 EXIT 7500 ENDIF 7461 7501 ENDIF 7462 7502 ji=ji+1 … … 7470 7510 & TRIM(fct_str(var__get_min))//" for variable "//TRIM(cd_name) ) 7471 7511 ELSE 7472 CALL logger_error("VAR GET MIN: invalid minimum value for "//& 7473 & "variable "//TRIM(cd_name)//". check namelist." ) 7512 CALL logger_error("VAR GET MIN: invalid minimum value ("//& 7513 & TRIM(cl_min)//") for variable "//TRIM(cd_name)//& 7514 & ". check namelist." ) 7474 7515 ENDIF 7475 7516 ENDIF … … 7489 7530 !> - change way to get information in namelist, 7490 7531 !> value follows string "max =" 7532 !> @date Feb, 2016 7533 !> - check character just after keyword 7491 7534 ! 7492 7535 !> @param[in] cd_name variable name … … 7511 7554 ! loop indices 7512 7555 INTEGER(i4) :: ji 7556 INTEGER(i4) :: jj 7513 7557 !---------------------------------------------------------------- 7514 7558 ! init … … 7521 7565 il_ind=INDEX(TRIM(cl_tmp),'max') 7522 7566 IF( il_ind /= 0 )THEN 7523 cl_max=fct_split(cl_tmp,2,'=') 7524 EXIT 7567 ! check character just after 7568 jj=il_ind+LEN('max') 7569 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7570 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7571 cl_max=fct_split(cl_tmp,2,'=') 7572 EXIT 7573 ENDIF 7525 7574 ENDIF 7526 7575 ji=ji+1 … … 7550 7599 !> @author J.Paul 7551 7600 !> @date June, 2015 - Initial Version 7601 !> @date Feb, 2016 7602 !> - check character just after keyword 7552 7603 ! 7553 7604 !> @param[in] cd_name variable name … … 7574 7625 ! loop indices 7575 7626 INTEGER(i4) :: ji 7627 INTEGER(i4) :: jj 7576 7628 !---------------------------------------------------------------- 7577 7629 ! init … … 7584 7636 il_ind=INDEX(TRIM(cl_tmp),'unf') 7585 7637 IF( il_ind /= 0 )THEN 7586 cl_unf=fct_split(cl_tmp,2,'=') 7587 EXIT 7638 ! check character just after 7639 jj=il_ind+LEN('unf') 7640 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7641 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7642 cl_unf=fct_split(cl_tmp,2,'=') 7643 EXIT 7644 ENDIF 7588 7645 ENDIF 7589 7646 ji=ji+1 … … 7626 7683 !> - change way to get information in namelist, 7627 7684 !> value follows string "int =" 7685 !> @date Feb, 2016 7686 !> - check character just after keyword 7628 7687 ! 7629 7688 !> @param[in] cd_name variable name … … 7663 7722 il_ind=INDEX(TRIM(cl_tmp),'int') 7664 7723 IF( il_ind /= 0 )THEN 7665 cl_int=fct_split(cl_tmp,2,'=') 7666 EXIT 7724 ! check character just after 7725 jj=il_ind+LEN('int') 7726 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7727 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7728 cl_int=fct_split(cl_tmp,2,'=') 7729 EXIT 7730 ENDIF 7667 7731 ENDIF 7668 7732 ji=ji+1 … … 7746 7810 !> - change way to get information in namelist, 7747 7811 !> value follows string "ext =" 7812 !> @date Feb, 2016 7813 !> - check character just after keyword 7748 7814 ! 7749 7815 !> @param[in] cd_name variable name … … 7778 7844 il_ind=INDEX(TRIM(cl_tmp),'ext') 7779 7845 IF( il_ind /= 0 )THEN 7780 cl_ext=fct_split(cl_tmp,2,'=') 7781 EXIT 7846 ! check character just after 7847 jj=il_ind+LEN('ext') 7848 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7849 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7850 cl_ext=fct_split(cl_tmp,2,'=') 7851 EXIT 7852 ENDIF 7782 7853 ENDIF 7783 7854 ji=ji+1 … … 7822 7893 !> - change way to get information in namelist, 7823 7894 !> value follows string "flt =" 7895 !> @date Feb, 2016 7896 !> - check character just after keyword 7824 7897 !> 7825 7898 !> @param[in] cd_name variable name … … 7852 7925 il_ind=INDEX(TRIM(cl_tmp),'flt') 7853 7926 IF( il_ind /= 0 )THEN 7854 cl_flt=fct_split(cl_tmp,2,'=') 7855 EXIT 7927 ! check character just after 7928 jj=il_ind+LEN('flt') 7929 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 7930 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 7931 cl_flt=fct_split(cl_tmp,2,'=') 7932 EXIT 7933 ENDIF 7856 7934 ENDIF 7857 7935 ji=ji+1 … … 7925 8003 !> @author J.Paul 7926 8004 !> @date June, 2015 - Initial Version 8005 !> @date Feb, 2016 8006 !> - check character just after keyword 7927 8007 ! 7928 8008 !> @param[in] cd_name variable name … … 7946 8026 ! loop indices 7947 8027 INTEGER(i4) :: ji 8028 INTEGER(i4) :: jj 7948 8029 !---------------------------------------------------------------- 7949 8030 … … 7955 8036 il_ind=INDEX(TRIM(cl_tmp),'unt') 7956 8037 IF( il_ind /= 0 )THEN 7957 var__get_unt=fct_split(cl_tmp,2,'=') 7958 EXIT 8038 ! check character just after 8039 jj=il_ind+LEN('unt') 8040 IF( TRIM(cl_tmp(jj:jj)) == ' ' .OR. & 8041 & TRIM(cl_tmp(jj:jj)) == '=' )THEN 8042 var__get_unt=fct_split(cl_tmp,2,'=') 8043 EXIT 8044 ENDIF 7959 8045 ENDIF 7960 8046 ji=ji+1 … … 8101 8187 8102 8188 !- change scale factor and offset to avoid mistake 8103 tl_att=att_init('scale_factor',1 )8189 tl_att=att_init('scale_factor',1._dp) 8104 8190 CALL var_move_att(td_var, tl_att) 8105 8191 8106 tl_att=att_init('add_offset',0 )8192 tl_att=att_init('add_offset',0._dp) 8107 8193 CALL var_move_att(td_var, tl_att) 8108 8194 ENDIF … … 8356 8442 8357 8443 END FUNCTION var_to_date 8444 !------------------------------------------------------------------- 8445 !> @brief This subroutine fill dummy variable array 8446 ! 8447 !> @author J.Paul 8448 !> @date September, 2015 - Initial Version 8449 ! 8450 !> @param[in] cd_dummy dummy configuration file 8451 !------------------------------------------------------------------- 8452 SUBROUTINE var_get_dummy( cd_dummy ) 8453 IMPLICIT NONE 8454 ! Argument 8455 CHARACTER(LEN=*), INTENT(IN) :: cd_dummy 8456 8457 ! local variable 8458 INTEGER(i4) :: il_fileid 8459 INTEGER(i4) :: il_status 8460 8461 LOGICAL :: ll_exist 8462 8463 ! loop indices 8464 ! namelist 8465 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumvar 8466 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumdim 8467 CHARACTER(LEN=lc), DIMENSION(ip_maxdum) :: cn_dumatt 8468 8469 !---------------------------------------------------------------- 8470 NAMELIST /namdum/ & !< dummy namelist 8471 & cn_dumvar, & !< variable name 8472 & cn_dumdim, & !< dimension name 8473 & cn_dumatt !< attribute name 8474 !---------------------------------------------------------------- 8475 8476 ! init 8477 cm_dumvar(:)='' 8478 8479 ! read namelist 8480 INQUIRE(FILE=TRIM(cd_dummy), EXIST=ll_exist) 8481 IF( ll_exist )THEN 8482 8483 il_fileid=fct_getunit() 8484 8485 OPEN( il_fileid, FILE=TRIM(cd_dummy), & 8486 & FORM='FORMATTED', & 8487 & ACCESS='SEQUENTIAL', & 8488 & STATUS='OLD', & 8489 & ACTION='READ', & 8490 & IOSTAT=il_status) 8491 CALL fct_err(il_status) 8492 IF( il_status /= 0 )THEN 8493 CALL logger_fatal("DIM GET DUMMY: opening "//TRIM(cd_dummy)) 8494 ENDIF 8495 8496 READ( il_fileid, NML = namdum ) 8497 cm_dumvar(:)=cn_dumvar(:) 8498 8499 CLOSE( il_fileid ) 8500 8501 ENDIF 8502 8503 END SUBROUTINE var_get_dummy 8504 !------------------------------------------------------------------- 8505 !> @brief This function check if variable is defined as dummy variable 8506 !> in configuraton file 8507 !> 8508 !> @author J.Paul 8509 !> @date September, 2015 - Initial Version 8510 ! 8511 !> @param[in] td_var variable structure 8512 !> @return true if variable is dummy variable 8513 !------------------------------------------------------------------- 8514 FUNCTION var_is_dummy(td_var) 8515 IMPLICIT NONE 8516 8517 ! Argument 8518 TYPE(TVAR), INTENT(IN) :: td_var 8519 8520 ! function 8521 LOGICAL :: var_is_dummy 8522 8523 ! loop indices 8524 INTEGER(i4) :: ji 8525 !---------------------------------------------------------------- 8526 8527 var_is_dummy=.FALSE. 8528 DO ji=1,ip_maxdum 8529 IF( fct_lower(td_var%c_name) == fct_lower(cm_dumvar(ji)) )THEN 8530 var_is_dummy=.TRUE. 8531 EXIT 8532 ENDIF 8533 ENDDO 8534 8535 END FUNCTION var_is_dummy 8358 8536 END MODULE var 8359 8537 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/src/vgrid.f90
r5616 r6455 291 291 END SUBROUTINE vgrid_zgr_z 292 292 !------------------------------------------------------------------- 293 !> @brief This subroutine 294 !> 295 !> @todo add subroutine description 296 !> 297 !> @param[inout] dd_bathy 298 !> @param[in] dd_gdepw 299 !> @param[in] dd_hmin 300 !> @param[in] dd_fill 293 301 !------------------------------------------------------------------- 294 302 SUBROUTINE vgrid_zgr_bat( dd_bathy, dd_gdepw, dd_hmin, dd_fill ) … … 371 379 !> - gdept, gdepw and e3 are positives 372 380 !> - gdept_ps, gdepw_ps and e3_ps are positives 373 ! 381 !> 374 382 !> @author A. Bozec, G. Madec 375 383 !> @date February, 2009 - F90: Free form and module … … 386 394 !> @param[in] dd_e3zps_min 387 395 !> @param[in] dd_e3zps_rat 396 !> @param[in] dd_fill 388 397 !------------------------------------------------------------------- 389 398 SUBROUTINE vgrid_zgr_zps( id_mbathy, dd_bathy, id_jpkmax, & … … 495 504 !> ** Action : - update mbathy: level bathymetry (in level index) 496 505 !> - update bathy : meter bathymetry (in meters) 497 506 !> 498 507 !> @author G.Madec 499 508 !> @date Marsh, 2008 - Original code -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/templates/create_bathy.nam
r5608 r6455 1 1 &namlog 2 cn_logfile= "bathy_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 4 in_maxerror= … … 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 16 17 &namfin 17 18 cn_coord1= 19 in_perio1= 20 ln_fillclosed= 18 21 / 19 22 … … 29 32 30 33 &namout 31 cn_fileout= "bathy_out.nc"34 cn_fileout= 32 35 / -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/templates/create_boundary.nam
r5608 r6455 1 1 &namlog 2 cn_logfile= "boundary.log"2 cn_logfile= 3 3 cn_verbosity= 4 4 in_maxerror = … … 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 41 42 42 43 &namvar 44 cn_varfile= 43 45 cn_varinfo= 44 cn_varfile=45 46 / 46 47 … … 63 64 64 65 &namout 65 cn_fileout= "boundary_out.nc"66 cn_fileout= 66 67 dn_dayofs= 67 68 ln_extrap= -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/templates/create_coord.nam
r5037 r6455 1 1 &namlog 2 cn_logfile= "coord_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 4 in_maxerror= … … 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 29 30 30 31 &namout 31 cn_fileout= "coord_out.nc"32 cn_fileout= 32 33 / 33 34 -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/templates/create_restart.nam
r5608 r6455 1 1 &namlog 2 cn_logfile= "restart_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 in_maxerror 4 in_maxerror= 5 5 / 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 41 42 42 43 &namvar 44 cn_varfile= 43 45 cn_varinfo= 44 cn_varfile=45 46 / 46 47 … … 51 52 52 53 &namout 53 cn_fileout= "restart_out.nc"54 cn_fileout= 54 55 ln_extrap= 55 in_nipro =56 in_niproc= 56 57 in_njproc= 57 58 in_nproc= -
branches/CNRS/dev_r6270_PISCES_QUOTA/NEMOGCM/TOOLS/SIREN/templates/merge_bathy.nam
r5037 r6455 1 1 &namlog 2 cn_logfile= "merge_out.log"2 cn_logfile= 3 3 cn_verbosity= 4 in_maxerror 4 in_maxerror= 5 5 / 6 6 7 7 &namcfg 8 cn_varcfg="./cfg/variable.cfg" 8 cn_varcfg= 9 cn_dumcfg= 9 10 / 10 11 … … 17 18 cn_bathy1= 18 19 in_perio1= 19 /20 21 &namvar22 cn_varinfo=23 20 / 24 21 … … 41 38 42 39 &namout 43 cn_fileout= "merge_out.nc"40 cn_fileout= 44 41 /
Note: See TracChangeset
for help on using the changeset viewer.